teal.modules.general coverage - 49.49%

Files
Source

# minimal implementation of ggplot2 mosaic after ggmosaic was archived in CRAN
#
# This was heavily inspired by github.com/haleyjeppson/ggmosaic package but
# simplified to only support 2 categorical variables

#' Mosaic Rectangles Layer for ggplot2
#'
#' Adds a mosaic-style rectangles layer to a ggplot, visualizing the
#' joint distribution of categorical variables.
#' Each rectangle's size reflects the proportion of observations for
#' combinations of `x` and `fill`.
#'
#' @param mapping Set of aesthetic mappings created by `aes()`. Must specify `x` and `fill`.
#' @param data The data to be displayed in this layer.
#' @param stat The statistical transformation to use on the data. Defaults to `"rects"`.
#' @param position Position adjustment. Defaults to `"identity"`.
#' @param ... Other arguments passed to `layer()`.
#' @param na.rm Logical. Should missing values be removed?
#' @param show.legend Logical. Should this layer be included in the legends?
#' @param inherit.aes Logical. If `FALSE`, overrides default aesthetics.
#'
#' @return A ggplot2 layer that adds mosaic rectangles to the plot.
#'
#' @examples
#' df <- data.frame(RACE = c("Black", "White", "Black", "Asian"), SEX = c("M", "M", "F", "F"))
#' library(ggplot2)
#' ggplot(df) +
#'   geom_mosaic(aes(x = RACE, fill = SEX))
#' @export
geom_mosaic <- function(mapping = NULL, data = NULL,
                        stat = "mosaic", position = "identity",
                        ...,
                        na.rm = FALSE, # nolint: object_name_linter.
                        show.legend = TRUE, # nolint: object_name_linter.
                        inherit.aes = TRUE) { # nolint: object_name_linter.

  aes_x <- mapping$x
  if (!is.null(aes_x)) {
    aes_x <- list(rlang::quo_get_expr(mapping$x))
    var_x <- paste0("x__", as.character(aes_x))
    mapping[[var_x]] <- mapping$x
  }

  aes_fill <- mapping$fill
  if (!is.null(aes_fill)) {
    aes_fill <- rlang::quo_text(mapping$fill)
  }

  mapping$x <- structure(1L)

  layer <- ggplot2::layer(
    geom = GeomMosaic,
    stat = "mosaic",
    data = data,
    mapping = mapping,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    check.aes = FALSE,
    params = list(na.rm = na.rm, ...)
  )
  list(layer, .scale_x_mosaic())
}

#' @keywords internal
GeomMosaic <- ggplot2::ggproto( # nolint: object_name_linter.
  "GeomMosaic", ggplot2::GeomRect,
  default_aes = ggplot2::aes(
    colour = NA, linewidth = 0.5, linetype = 1, alpha = 1, fill = "grey30"
  ),
  draw_panel = function(data, panel_params, coord) {
    if (all(is.na(data$colour))) data$colour <- scales::alpha(data$fill, data$alpha)
    ggplot2::GeomRect$draw_panel(data, panel_params, coord)
  },
  required_aes = c("xmin", "xmax", "ymin", "ymax")
)

#' @keywords internal
StatMosaic <- ggplot2::ggproto( # nolint: object_name_linter.
  "StatMosaic", ggplot2::Stat,
  required_aes = c("x", "fill"),
  compute_group = function(data, scales) data,
  compute_panel = function(data, scales) {
    data$x <- data[, grepl("x__", colnames(data))]
    result <- .calculate_coordinates(data)

    results_non_zero <- result[result$.n != 0, ]
    breaks <- unique(with(results_non_zero, (xmin + xmax) / 2))
    labels <- unique(results_non_zero$x)
    result$x <- list(list2env(list(breaks = breaks[breaks != 0], labels = labels[breaks != 0])))

    result$group <- 1
    result$PANEL <- unique(data$PANEL)
    result
  }
)

#' Determining scales for mosaics
#'
#' @param breaks,labels,minor_breaks One of:
#' - `NULL` for no breaks / labels.
#' - [ggplot2::waiver()] for the default breaks / labels computed by the scale.
#' - A numeric / character vector giving the positions of the breaks / labels.
#' - A function.
#' See [ggplot2::scale_x_continuous()] for more details.
#' @param na.value The value to be used for `NA` values.
#' @param position For position scales, The position of the axis.
#' left or right for y axes, top or bottom for x axes.
#' @param ... other arguments passed to `continuous_scale()`.
#' @keywords internal
.scale_x_mosaic <- function(breaks = unique,
                            minor_breaks = NULL,
                            labels = unique,
                            na.value = NA_real_, # nolint: object_name_linter.
                            position = "bottom",
                            ...) {
  ggplot2::continuous_scale(
    aesthetics = c(
      "x", "xmin", "xmax", "xend", "xintercept", "xmin_final", "xmax_final",
      "xlower", "xmiddle", "xupper"
    ),
    palette = identity,
    breaks = breaks,
    minor_breaks = minor_breaks,
    labels = labels,
    na.value = na.value,
    position = position,
    super = ScaleContinuousMosaic, ,
    guide = ggplot2::waiver(),
    ...
  )
}

#' @keywords internal
ScaleContinuousMosaic <- ggplot2::ggproto( # nolint: object_name_linter.
  "ScaleContinuousMosaic", ggplot2::ScaleContinuousPosition,
  train = function(self, x) {
    if (length(x) == 0) {
      return()
    }
    if (is.list(x)) {
      scale_x <- x[[1]]
      # re-assign the scale values now that we have the information - but only if necessary
      if (is.function(self$breaks)) self$breaks <- scale_x$breaks
      if (is.function(self$labels)) self$labels <- as.vector(scale_x$labels)
      return(NULL)
    }
    if (is_discrete(x)) {
      self$range$train(x = c(0, 1))
      return(NULL)
    }
    self$range$train(x, call = self$call)
  },
  map = function(self, x, limits = self$get_limits()) {
    if (is_discrete(x)) {
      return(x)
    }
    if (is.list(x)) {
      return(0)
    } # need a number
    scaled <- as.numeric(self$oob(x, limits))
    ifelse(!is.na(scaled), scaled, self$na.value)
  },
  dimension = function(self, expand = c(0, 0)) c(-0.05, 1.05)
)

#' @noRd
is_discrete <- function(x) is.factor(x) || is.character(x) || is.logical(x)

#' @describeIn geom_mosaic
#' Computes the coordinates for rectangles in a mosaic plot based
#' on combinations of `x` and `fill` variables.
#' For each unique `x` and `fill`, calculates the proportional
#' widths and heights, stacking rectangles within each `x` group.
#'
#' ### Value
#'
#' A data frame with columns: `x`, `fill`, `xmin`, `xmax`, `ymin`, `ymax`,
#' representing the position and size of each rectangle.
#'
#' @keywords internal
.calculate_coordinates <- function(data) {
  # Example: compute rectangles from x and y
  result <- data |>
    # Count combinations of X and Y
    dplyr::count(.data$x, .data$fill, .drop = FALSE) |>
    # Compute total for each X group
    dplyr::mutate(
      .by = .data$x,
      x_total = sum(.data$n),
      prop = .data$n / .data$x_total,
      prop = dplyr::if_else(is.nan(.data$prop), 0, .data$prop)
    ) |>
    dplyr::arrange(dplyr::desc(.data$x_total), .data$x, .data$fill) |>
    # Compute total sample size to turn counts into widths
    dplyr::mutate(
      N_total = dplyr::n(),
      x_width = .data$x_total / .data$N_total
    ) |>
    # Convert counts to x widths
    dplyr::mutate(
      .by = .data$x,
      x_width_last = dplyr::if_else(dplyr::row_number() == dplyr::n(), .data$x_width, 0)
    ) |>
    # Compute x-min/x-max for each group
    dplyr::mutate(
      xmin = cumsum(dplyr::lag(.data$x_width_last, default = 0)),
      xmax = .data$xmin + .data$x_width
    ) |>
    # Compute y-min/y-max for stacked proportions
    dplyr::mutate(
      .by = .data$x,
      ymin = c(0, utils::head(cumsum(.data$prop), -1)),
      ymax = cumsum(.data$prop)
    ) |>
    dplyr::mutate(
      xmin = .data$xmin / max(.data$xmax),
      xmax = .data$xmax / max(.data$xmax),
      xmin = dplyr::if_else(.data$n == 0, 0, .data$xmin + 0.005),
      xmax = dplyr::if_else(.data$n == 0, 0, .data$xmax - 0.005),
      ymin = dplyr::if_else(.data$n == 0, 0, .data$ymin + 0.005),
      ymax = dplyr::if_else(.data$n == 0, 0, .data$ymax - 0.005)
    ) |>
    dplyr::select(.data$x, .data$fill, .data$xmin, .data$xmax, .data$ymin, .data$ymax, .n = .data$n)
  result
}

#' Shared parameters documentation
#'
#' Defines common arguments shared across multiple functions in the package
#' to avoid repetition by using `inheritParams`.
#'
#' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of
#' `value`, `min`, and `max` intended for use with a slider UI element.
#' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of
#' `value`, `min`, and `max` for a slider encoding the plot width.
#' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not
#' rotate by default (`FALSE`).
#' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`.
#' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]
#' with settings for the module plot.
#' The argument is merged with options variable `teal.ggplot2_args` and default module setup.
#'
#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
#' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]
#' with settings for the module table.
#' The argument is merged with options variable `teal.basic_table_args` and default module setup.
#'
#' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
#' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output,
#' providing context or a title.
#'  with text placed before the output to put the output into context. For example a title.
#' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output,
#' adding context or further instructions. Elements like `shiny::helpText()` are useful.
#' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity.
#' - When the length of `alpha` is one: the plot points will have a fixed opacity.
#' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on
#' vector of `value`, `min`, and `max`.
#' @param size (`integer(1)` or `integer(3)`) optional, specifies point size.
#' - When the length of `size` is one: the plot point sizes will have a fixed size.
#' - When the length of `size` is three: the plot points size are dynamically adjusted based on
#' vector of `value`, `min`, and `max`.
#' @param decorators `r lifecycle::badge("experimental")`
#' (named `list` of lists of `teal_transform_module`) optional,
#' decorator for tables or plots included in the module output reported.
#' The decorators are applied to the respective output objects.
#'
#' See section "Decorating Module" below for more details.
#'
#' @return Object of class `teal_module` to be used in `teal` applications.
#'
#' @name shared_params
#' @keywords internal
NULL

#' Add labels for facets to a `ggplot2` object
#'
#' Enhances a `ggplot2` plot by adding labels that describe
#' the faceting variables along the x and y axes.
#'
#' @param p (`ggplot2`) object to which facet labels will be added.
#' @param xfacet_label (`character`) Label for the facet along the x-axis.
#' If `NULL`, no label is added. If a vector, labels are joined with " & ".
#' @param yfacet_label (`character`) Label for the facet along the y-axis.
#' Similar behavior to `xfacet_label`.
#'
#' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`)
#'
#' @examples
#' library(ggplot2)
#' library(grid)
#'
#' p <- ggplot(mtcars) +
#'   aes(x = mpg, y = disp) +
#'   geom_point() +
#'   facet_grid(gear ~ cyl)
#'
#' xfacet_label <- "cylinders"
#' yfacet_label <- "gear"
#' res <- add_facet_labels(p, xfacet_label, yfacet_label)
#' grid.newpage()
#' grid.draw(res)
#'
#' grid.newpage()
#' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))
#' grid.newpage()
#' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))
#' grid.newpage()
#' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))
#'
#' @export
#'
add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
  checkmate::assert_class(p, classes = "ggplot")
  checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)
  checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)
  if (is.null(xfacet_label) && is.null(yfacet_label)) {
    return(ggplot2::ggplotGrob(p))
  }
  grid::grid.grabExpr({
    g <- ggplot2::ggplotGrob(p)

    # we are going to replace these, so we make sure they have nothing in them
    checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
    checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")

    xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
    xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")
    yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
    yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")
    yaxis_label_grob$children[[1]]$rot <- 270

    top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")
    right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")

    grid::grid.newpage()
    grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))
    grid::grid.draw(g)
    grid::upViewport(1)

    # draw x facet
    if (!is.null(xfacet_label)) {
      grid::pushViewport(grid::viewport(
        x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),
        height = top_height, just = c("left", "bottom"), name = "topxaxis"
      ))
      grid::grid.draw(xaxis_label_grob)
      grid::upViewport(1)
    }

    # draw y facet
    if (!is.null(yfacet_label)) {
      grid::pushViewport(grid::viewport(
        x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,
        height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
      ))
      grid::grid.draw(yaxis_label_grob)
      grid::upViewport(1)
    }
  })
}

#' Call a function with a character vector for the `...` argument
#'
#' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`.
#' @param str_args (`character`) A character vector that the function shall be executed with
#'
#' @return
#' Value of call to `fun` with arguments specified in `str_args`.
#'
#' @keywords internal
call_fun_dots <- function(fun, str_args) {
  do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
}

#' Generate a string for a variable including its label
#'
#' @param var_names (`character`) Name of variable to extract labels from.
#' @param dataset (`dataset`) Name of analysis dataset.
#' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label.
#' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80.
#'
#' @return (`character`) String with variable name and label.
#'
#' @keywords internal
#'
varname_w_label <- function(var_names,
                            dataset,
                            wrap_width = 80,
                            prefix = NULL,
                            suffix = NULL) {
  add_label <- function(var_names) {
    label <- vapply(
      dataset[var_names], function(x) {
        attr_label <- attr(x, "label")
        `if`(is.null(attr_label), "", attr_label)
      },
      character(1)
    )

    if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
      paste0(prefix, label, " [", var_names, "]", suffix)
    } else {
      var_names
    }
  }

  if (length(var_names) < 1) {
    NULL
  } else if (length(var_names) == 1) {
    stringr::str_wrap(add_label(var_names), width = wrap_width)
  } else if (length(var_names) > 1) {
    stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)
  }
}

# see vignette("ggplot2-specs", package="ggplot2")
shape_names <- c(
  "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
  "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
  "diamond", paste("diamond", c("open", "filled", "plus")),
  "triangle", paste("triangle", c("open", "filled", "square")),
  paste("triangle down", c("open", "filled")),
  "plus", "cross", "asterisk"
)

#' Get icons to represent variable types in dataset
#'
#' @param var_type (`character`) of R internal types (classes).
#' @return (`character`) vector of HTML icons corresponding to data type in each column.
#' @keywords internal
variable_type_icons <- function(var_type) {
  checkmate::assert_character(var_type, any.missing = FALSE)

  class_to_icon <- list(
    numeric = "arrow-up-1-9",
    integer = "arrow-up-1-9",
    logical = "pause",
    Date = "calendar",
    POSIXct = "calendar",
    POSIXlt = "calendar",
    factor = "chart-bar",
    character = "keyboard",
    primary_key = "key",
    unknown = "circle-question"
  )
  class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))

  unname(vapply(
    var_type,
    FUN.VALUE = character(1),
    FUN = function(class) {
      if (class == "") {
        class
      } else if (is.null(class_to_icon[[class]])) {
        class_to_icon[["unknown"]]
      } else {
        class_to_icon[[class]]
      }
    }
  ))
}

#' JavaScript expression to check if a tab is active
#'
#' @param id (`character(1)`) the id of the tab panel with tabs.
#' @param name (`character(1)`) the name of the tab.
#' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine
#' if the specified tab is active.
#' @keywords internal
#'
is_tab_active_js <- function(id, name) {
  # supporting the bs3 and higher version at the same time
  sprintf(
    "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'",
    id, name
  )
}

#' Assert single selection on `data_extract_spec` object
#' Helper to reduce code in assertions
#' @noRd
#'
assert_single_selection <- function(x,
                                    .var.name = checkmate::vname(x)) { # nolint: object_name.
  if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
    stop("'", .var.name, "' should not allow multiple selection")
  }
  invisible(TRUE)
}

#' Wrappers around `srv_transform_teal_data` that allows to decorate the data
#' @inheritParams teal::srv_transform_teal_data
#' @inheritParams teal.reporter::`eval_code,teal_report-method`
#' @param expr (`reactive`) with expression to evaluate on the output of the
#' decoration. It must be compatible with `code` argument of [teal.code::eval_code()].
#' Default is `NULL` which won't evaluate any appending code.
#' @details
#' `srv_decorate_teal_data` is a wrapper around `srv_transform_teal_data` that
#' allows to decorate the data with additional expressions.
#' When original `teal_data` object is in error state, it will show that error
#' first.
#'
#' @keywords internal
srv_decorate_teal_data <- function(id, data, decorators, expr) {
  checkmate::assert_class(data, classes = "reactive")
  checkmate::assert_list(decorators, "teal_transform_module")

  no_expr <- missing(expr)

  moduleServer(id, function(input, output, session) {
    decorated_output <- srv_transform_teal_data("inner", data = data, transformators = decorators)

    expr_r <- if (is.reactive(expr)) expr else reactive(expr)

    reactive({
      req(decorated_output())
      if (no_expr) {
        decorated_output()
      } else {
        teal.code::eval_code(decorated_output(), expr_r())
      }
    })
  })
}

#' @rdname srv_decorate_teal_data
#' @details
#' `ui_decorate_teal_data` is a wrapper around `ui_transform_teal_data`.
#' @keywords internal
ui_decorate_teal_data <- function(id, decorators, ...) {
  teal::ui_transform_teal_data(NS(id, "inner"), transformators = decorators, ...)
}

#' Internal function to check if decorators is a valid object
#' @noRd
check_decorators <- function(x, names = NULL) { # nolint: object_name.

  check_message <- checkmate::check_list(x, names = "named")

  if (!is.null(names)) {
    if (isTRUE(check_message)) {
      if (length(names(x)) != length(unique(names(x)))) {
        check_message <- sprintf(
          "The `decorators` must contain unique names from these names: %s.",
          paste(names, collapse = ", ")
        )
      }
    } else {
      check_message <- sprintf(
        "The `decorators` must be a named list from these names: %s.",
        paste(names, collapse = ", ")
      )
    }
  }

  if (!isTRUE(check_message)) {
    return(check_message)
  }

  valid_elements <- vapply(
    x,
    checkmate::test_class,
    classes = "teal_transform_module",
    FUN.VALUE = logical(1L)
  )

  if (all(valid_elements)) {
    return(TRUE)
  }

  "Make sure that the named list contains 'teal_transform_module' objects created using `teal_transform_module()`."
}
#' Internal assertion on decorators
#' @noRd
assert_decorators <- checkmate::makeAssertionFunction(check_decorators)

#' Subset decorators based on the scope
#'
#' @param scope (`character`) a character vector of decorator names to include.
#' @param decorators (named `list`) of list decorators to subset.
#'
#' @return Subsetted list with all decorators to include.
#' It can be an empty list if none of the scope exists in `decorators` argument.
#' @keywords internal
select_decorators <- function(decorators, scope) {
  checkmate::assert_character(scope, null.ok = TRUE)
  if (scope %in% names(decorators)) {
    decorators[scope]
  } else {
    list()
  }
}

#' Set the attributes of the last chunk outputs
#' @param teal_card (`teal_card`) object to modify.
#' @param attributes (`list`) of attributes to set on the last chunk outputs.
#' @param n (`integer(1)`) number of the last element of `teal_card` to modify.
#' it will only change `chunk_output` objects.
#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
#' @keywords internal
set_chunk_attrs <- function(teal_card,
                            attributes,
                            n = 1,
                            inner_classes = NULL,
                            quiet = FALSE) {
  checkmate::assert_class(teal_card, "teal_card")
  checkmate::assert_list(attributes, names = "unique")
  checkmate::assert_int(n, lower = 1)
  checkmate::assert_character(inner_classes, null.ok = TRUE)
  checkmate::assert_flag(quiet)

  if (!inherits(teal_card[[length(teal_card)]], "chunk_output")) {
    if (!quiet) {
      warning("The last element of the `teal_card` is not a `chunk_output` object. No attributes were modified.")
    }
    return(teal_card)
  }

  for (ix in seq_len(length(teal_card))) {
    if (ix > n) {
      break
    }
    current_ix <- length(teal_card) + 1 - ix
    if (!inherits(teal_card[[current_ix]], "chunk_output")) {
      if (!quiet) {
        warning(
          "The ", ix,
          " to last element of the `teal_card` is not a `chunk_output` object. Skipping any further modifications."
        )
      }
      return(teal_card)
    }

    if (
      length(inner_classes) > 0 &&
        length(teal_card[[current_ix]]) >= 1 &&
        !checkmate::test_multi_class(teal_card[[current_ix]][[1]], inner_classes)
    ) {
      next
    }

    attributes(teal_card[[current_ix]]) <- utils::modifyList(
      attributes(teal_card[[current_ix]]),
      attributes
    )
  }

  teal_card
}

#' Create a reactive that sets plot dimensions on a `teal_card`
#'
#' This is a convenience function that creates a reactive expression that
#' automatically sets the `dev.width` and `dev.height` attributes on the last
#' chunk outputs of a `teal_card` based on plot dimensions from a plot widget.
#'
#' @param pws (`plot_widget`) plot widget that provides dimensions via `dim()` method
#' @param q_r (`reactive`) reactive expression that returns a `teal_reporter`
#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
#'
#' @return A reactive expression that returns the `teal_card` with updated dimensions
#'
#' @keywords internal
set_chunk_dims <- function(pws, q_r, inner_classes = NULL) {
  checkmate::assert_list(pws)
  checkmate::assert_names(names(pws), must.include = "dim")
  checkmate::assert_class(pws$dim, "reactive")
  checkmate::assert_class(q_r, "reactive")
  checkmate::assert_character(inner_classes, null.ok = TRUE)

  reactive({
    pws_dim <- stats::setNames(as.list(req(pws$dim())), c("width", "height"))
    if (identical(pws_dim$width, "auto")) { # ignore non-numeric values (such as "auto")
      pws_dim$width <- NULL
    }
    if (identical(pws_dim$height, "auto")) { # ignore non-numeric values (such as "auto")
      pws_dim$height <- NULL
    }
    q <- req(q_r())
    teal.reporter::teal_card(q) <- set_chunk_attrs(
      teal.reporter::teal_card(q),
      list(dev.width = pws_dim$width, dev.height = pws_dim$height),
      inner_classes = inner_classes
    )
    q
  })
}

1		.onLoad <- function(libname, pkgname) {
2	!	teal.logger::register_logger(namespace = "teal.modules.general")
3	!	teal.logger::register_handlers("teal.modules.general")
4		}
5
6		### global variables
7		ggplot_themes <- c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void")
8
9		#' @importFrom lifecycle deprecated
10		interactive <- NULL

1		#' `teal` module: Cross-table
2		#'
3		#' Generates a simple cross-table of two variables from a dataset with custom
4		#' options for showing percentages and sub-totals.
5		#'
6		#' @inheritParams teal::module
7		#' @inheritParams shared_params
8		#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
9		#' Object with all available choices with pre-selected option for variable X - row values.
10		#' In case of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be
11		#' rendered according to selection order.
12		#' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)
13		#' Object with all available choices with pre-selected option for variable Y - column values.
14		#'
15		#' `data_extract_spec` must not allow multiple selection in this case.
16		#' @param show_percentage (`logical(1)`)
17		#' Indicates whether to show percentages (relevant only when `x` is a `factor`).
18		#' Defaults to `TRUE`.
19		#' @param show_total (`logical(1)`)
20		#' Indicates whether to show total column.
21		#' Defaults to `TRUE`.
22		#' @param remove_zero_columns (`logical(1)`)
23		#' Indicates whether to remove columns that contain only zeros from the output table.
24		#' Defaults to `FALSE`.
25		#'
26		#' @note For more examples, please see the vignette "Using cross table" via
27		#' `vignette("using-cross-table", package = "teal.modules.general")`.
28		#'
29		#' @inherit shared_params return
30		#'
31		#' @section Table Settings:
32		#' The module provides several table settings that can be adjusted:
33		#' \itemize{
34		#' \item \code{Show column percentage}: Shows column percentages when enabled
35		#' \item \code{Show total column}: Shows a total column when enabled
36		#' \item \code{Remove zero-only columns}: Removes columns that contain only zeros from the output table
37		#' }
38		#'
39		#' @section Decorating Module:
40		#'
41		#' This module generates the following objects, which can be modified in place using decorators:
42		#' - `table` (`ElementaryTable` - output of `rtables::build_table`)
43		#'
44		#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
45		#' The name of this list corresponds to the name of the output to which the decorator is applied.
46		#' See code snippet below:
47		#'
48		#' ```
49		#' tm_t_crosstable(
50		#' ..., # arguments for module
51		#' decorators = list(
52		#' table = teal_transform_module(...) # applied to the `table` output
53		#' )
54		#' )
55		#' ```
56		#' For additional details and examples of decorators, refer to the vignette
57		#' `vignette("decorate-module-output", package = "teal.modules.general")`.
58		#'
59		#' To learn more please refer to the vignette
60		#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
61		#'
62		#' @inheritSection teal::example_module Reporting
63		#'
64		#' @examplesShinylive
65		#' library(teal.modules.general)
66		#' interactive <- function() TRUE
67		#' {{ next_example }}
68		#' @examples
69		#' # general data example
70		#' data <- teal_data()
71		#' data <- within(data, {
72		#' mtcars <- mtcars
73		#' for (v in c("cyl", "vs", "am", "gear")) {
74		#' mtcars[[v]] <- as.factor(mtcars[[v]])
75		#' }
76		#' mtcars[["primary_key"]] <- seq_len(nrow(mtcars))
77		#' })
78		#' join_keys(data) <- join_keys(join_key("mtcars", "mtcars", "primary_key"))
79		#'
80		#' app <- init(
81		#' data = data,
82		#' modules = modules(
83		#' tm_t_crosstable(
84		#' label = "Cross Table",
85		#' x = data_extract_spec(
86		#' dataname = "mtcars",
87		#' select = select_spec(
88		#' label = "Select variable:",
89		#' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
90		#' selected = c("cyl", "gear"),
91		#' multiple = TRUE,
92		#' ordered = TRUE,
93		#' fixed = FALSE
94		#' )
95		#' ),
96		#' y = data_extract_spec(
97		#' dataname = "mtcars",
98		#' select = select_spec(
99		#' label = "Select variable:",
100		#' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
101		#' selected = "vs",
102		#' multiple = FALSE,
103		#' fixed = FALSE
104		#' )
105		#' )
106		#' )
107		#' )
108		#' )
109		#' if (interactive()) {
110		#' shinyApp(app$ui, app$server)
111		#' }
112		#'
113		#' @examplesShinylive
114		#' library(teal.modules.general)
115		#' interactive <- function() TRUE
116		#' {{ next_example }}
117		#' @examples
118		#' # CDISC data example
119		#' data <- teal_data()
120		#' data <- within(data, {
121		#' ADSL <- teal.data::rADSL
122		#' })
123		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
124		#'
125		#' app <- init(
126		#' data = data,
127		#' modules = modules(
128		#' tm_t_crosstable(
129		#' label = "Cross Table",
130		#' x = data_extract_spec(
131		#' dataname = "ADSL",
132		#' select = select_spec(
133		#' label = "Select variable:",
134		#' choices = variable_choices(data[["ADSL"]], subset = function(data) {
135		#' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
136		#' return(names(data)[idx])
137		#' }),
138		#' selected = "COUNTRY",
139		#' multiple = TRUE,
140		#' ordered = TRUE,
141		#' fixed = FALSE
142		#' )
143		#' ),
144		#' y = data_extract_spec(
145		#' dataname = "ADSL",
146		#' select = select_spec(
147		#' label = "Select variable:",
148		#' choices = variable_choices(data[["ADSL"]], subset = function(data) {
149		#' idx <- vapply(data, is.factor, logical(1))
150		#' return(names(data)[idx])
151		#' }),
152		#' selected = "SEX",
153		#' multiple = FALSE,
154		#' fixed = FALSE
155		#' )
156		#' )
157		#' )
158		#' )
159		#' )
160		#' if (interactive()) {
161		#' shinyApp(app$ui, app$server)
162		#' }
163		#'
164		#' @export
165		#'
166		tm_t_crosstable <- function(label = "Cross Table",
167		x,
168		y,
169		show_percentage = TRUE,
170		show_total = TRUE,
171		remove_zero_columns = FALSE,
172		pre_output = NULL,
173		post_output = NULL,
174		basic_table_args = teal.widgets::basic_table_args(),
175		transformators = list(),
176		decorators = list()) {
177	17x	message("Initializing tm_t_crosstable")
178
179		# Normalize the parameters
180	11x	if (inherits(x, "data_extract_spec")) x <- list(x)
181	11x	if (inherits(y, "data_extract_spec")) y <- list(y)
182
183		# Start of assertions
184	17x	checkmate::assert_string(label)
185	16x	checkmate::assert_list(x, types = "data_extract_spec")
186
187	15x	checkmate::assert_list(y, types = "data_extract_spec")
188	14x	assert_single_selection(y)
189
190	13x	checkmate::assert_flag(show_percentage)
191	12x	checkmate::assert_flag(show_total)
192	11x	checkmate::assert_flag(remove_zero_columns)
193	10x	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
194	10x	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
195	10x	checkmate::assert_class(basic_table_args, classes = "basic_table_args")
196
197	10x	assert_decorators(decorators, "table")
198		# End of assertions
199
200		# Make UI args
201	9x	ui_args <- as.list(environment())
202
203	9x	server_args <- list(
204	9x	label = label,
205	9x	x = x,
206	9x	y = y,
207	9x	remove_zero_columns = remove_zero_columns,
208	9x	basic_table_args = basic_table_args,
209	9x	decorators = decorators
210		)
211
212	9x	ans <- module(
213	9x	label = label,
214	9x	server = srv_t_crosstable,
215	9x	ui = ui_t_crosstable,
216	9x	ui_args = ui_args,
217	9x	server_args = server_args,
218	9x	transformators = transformators,
219	9x	datanames = teal.transform::get_extract_datanames(list(x = x, y = y))
220		)
221	9x	attr(ans, "teal_bookmarkable") <- TRUE
222	9x	ans
223		}
224
225		# UI function for the cross-table module
226		ui_t_crosstable <- function(id, x, y, show_percentage, show_total, remove_zero_columns, pre_output, post_output, ...) {
227	!	args <- list(...)
228	!	ns <- NS(id)
229	!	is_single_dataset <- teal.transform::is_single_dataset(x, y)
230
231	!	join_default_options <- c(
232	!	"Full Join" = "dplyr::full_join",
233	!	"Inner Join" = "dplyr::inner_join",
234	!	"Left Join" = "dplyr::left_join",
235	!	"Right Join" = "dplyr::right_join"
236		)
237
238	!	teal.widgets::standard_layout(
239	!	output = teal.widgets::white_small_well(
240	!	textOutput(ns("title")),
241	!	teal.widgets::table_with_settings_ui(ns("table"))
242		),
243	!	encoding = tags$div(
244	!	tags$label("Encodings", class = "text-primary"),
245	!	teal.transform::datanames_input(list(x, y)),
246	!	teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
247	!	teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
248	!	teal.widgets::optionalSelectInput(
249	!	ns("join_fun"),
250	!	label = "Row to Column type of join",
251	!	choices = join_default_options,
252	!	selected = join_default_options[1],
253	!	multiple = FALSE
254		),
255	!	tags$hr(),
256	!	bslib::accordion(
257	!	open = TRUE,
258	!	bslib::accordion_panel(
259	!	title = "Table settings",
260	!	checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
261	!	checkboxInput(ns("show_total"), "Show total column", value = show_total),
262	!	checkboxInput(ns("remove_zero_columns"), "Remove zero-only columns", value = remove_zero_columns)
263		)
264		),
265	!	ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "table"))
266		),
267	!	pre_output = pre_output,
268	!	post_output = post_output
269		)
270		}
271
272		# Server function for the cross-table module
273		srv_t_crosstable <- function(id, data, label, x, y, remove_zero_columns, basic_table_args, decorators) {
274	3x	checkmate::assert_class(data, "reactive")
275	3x	checkmate::assert_class(isolate(data()), "teal_data")
276	3x	moduleServer(id, function(input, output, session) {
277	3x	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
278
279	3x	selector_list <- teal.transform::data_extract_multiple_srv(
280	3x	data_extract = list(x = x, y = y),
281	3x	datasets = data,
282	3x	select_validation_rule = list(
283	3x	x = shinyvalidate::sv_required("Please define column for row variable."),
284	3x	y = shinyvalidate::sv_required("Please define column for column variable.")
285		)
286		)
287
288	3x	iv_r <- reactive({
289	3x	iv <- shinyvalidate::InputValidator$new()
290	3x	iv$add_rule("join_fun", function(value) {
291	12x	if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
292	!	if (!shinyvalidate::input_provided(value)) {
293	!	"Please select a joining function."
294		}
295		}
296		})
297	3x	teal.transform::compose_and_enable_validators(iv, selector_list)
298		})
299
300	3x	observeEvent(
301	3x	eventExpr = {
302	3x	req(!is.null(selector_list()$x()) && !is.null(selector_list()$y()))
303	3x	list(selector_list()$x(), selector_list()$y())
304		},
305	3x	handlerExpr = {
306	3x	if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
307	3x	shinyjs::hide("join_fun")
308		} else {
309	!	shinyjs::show("join_fun")
310		}
311		}
312		)
313
314	3x	merge_function <- reactive({
315	3x	if (is.null(input$join_fun)) {
316	3x	"dplyr::full_join"
317		} else {
318	!	input$join_fun
319		}
320		})
321
322	3x	anl_merged_input <- teal.transform::merge_expression_srv(
323	3x	datasets = data,
324	3x	selector_list = selector_list,
325	3x	merge_function = merge_function
326		)
327	3x	qenv <- reactive({
328	3x	obj <- data()
329	3x	teal.reporter::teal_card(obj) <-
330	3x	c(
331	3x	teal.reporter::teal_card(obj),
332	3x	teal.reporter::teal_card("## Module's output(s)")
333		)
334	3x	teal.code::eval_code(obj, "library(rtables);library(tern);library(dplyr)")
335		})
336	3x	anl_merged_q <- reactive({
337	3x	req(anl_merged_input())
338	3x	qenv() %>%
339	3x	teal.code::eval_code(as.expression(anl_merged_input()$expr))
340		})
341
342	3x	merged <- list(
343	3x	anl_input_r = anl_merged_input,
344	3x	anl_q_r = anl_merged_q
345		)
346
347	3x	output_q <- reactive({
348	3x	teal::validate_inputs(iv_r())
349	3x	ANL <- merged$anl_q_r()[["ANL"]]
350
351		# As this is a summary
352	3x	x_name <- as.vector(merged$anl_input_r()$columns_source$x)
353	3x	y_name <- as.vector(merged$anl_input_r()$columns_source$y)
354
355	3x	teal::validate_has_data(ANL, 3)
356	3x	teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)
357
358	3x	is_allowed_class <- function(x) is.numeric(x) \|\| is.factor(x) \|\| is.character(x) \|\| is.logical(x)
359	3x	validate(need(
360	3x	all(vapply(ANL[x_name], is_allowed_class, logical(1))),
361	3x	"Selected row variable has an unsupported data type."
362		))
363	3x	validate(need(
364	3x	is_allowed_class(ANL[[y_name]]),
365	3x	"Selected column variable has an unsupported data type."
366		))
367
368	3x	show_percentage <- input$show_percentage
369	3x	show_total <- input$show_total
370	3x	remove_zero_columns <- input$remove_zero_columns
371
372	3x	plot_title <- paste(
373	3x	"Cross-Table of",
374	3x	paste0(varname_w_label(x_name, ANL), collapse = ", "),
375	3x	"(rows)", "vs.",
376	3x	varname_w_label(y_name, ANL),
377	3x	"(columns)"
378		)
379
380	3x	labels_vec <- vapply(
381	3x	x_name,
382	3x	varname_w_label,
383	3x	character(1),
384	3x	ANL
385		)
386
387	3x	obj <- merged$anl_q_r()
388	3x	teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "### Table")
389	3x	obj <- teal.code::eval_code(
390	3x	obj,
391	3x	substitute(
392	3x	expr = {
393	3x	title <- plot_title
394		},
395	3x	env = list(plot_title = plot_title)
396		)
397		) %>%
398	3x	teal.code::eval_code(
399	3x	substitute(
400	3x	expr = {
401	3x	table <- basic_tables %>%
402	3x	split_call %>% # styler: off
403	3x	rtables::add_colcounts() %>%
404	3x	tern::analyze_vars(
405	3x	vars = x_name,
406	3x	var_labels = labels_vec,
407	3x	na.rm = FALSE,
408	3x	denom = "N_col",
409	3x	.stats = c("mean_sd", "median", "range", count_value)
410		)
411		},
412	3x	env = list(
413	3x	basic_tables = teal.widgets::parse_basic_table_args(
414	3x	basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args)
415		),
416	3x	split_call = if (show_total) {
417	3x	substitute(
418	3x	expr = rtables::split_cols_by(
419	3x	y_name,
420	3x	split_fun = rtables::add_overall_level(label = "Total", first = FALSE)
421		),
422	3x	env = list(y_name = y_name)
423		)
424		} else {
425	!	substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name))
426		},
427	3x	x_name = x_name,
428	3x	labels_vec = labels_vec,
429	3x	count_value = ifelse(show_percentage, "count_fraction", "count")
430		)
431		)
432		) %>%
433	3x	teal.code::eval_code(
434	3x	expression(ANL <- tern::df_explicit_na(ANL))
435		)
436
437	3x	if (remove_zero_columns) {
438	!	obj <- obj %>%
439	!	teal.code::eval_code(
440	!	substitute(
441	!	expr = {
442	!	ANL[[y_name]] <- droplevels(ANL[[y_name]])
443	!	table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ])
444		},
445	!	env = list(y_name = y_name)
446		)
447		)
448		} else {
449	3x	obj <- obj %>%
450	3x	teal.code::eval_code(
451	3x	substitute(
452	3x	expr = {
453	3x	table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ])
454		},
455	3x	env = list(y_name = y_name)
456		)
457		)
458		}
459	3x	obj
460		})
461
462	3x	decorated_output_q <- srv_decorate_teal_data(
463	3x	id = "decorator",
464	3x	data = output_q,
465	3x	decorators = select_decorators(decorators, "table"),
466	3x	expr = quote(table)
467		)
468
469	3x	output$title <- renderText(req(decorated_output_q())[["title"]])
470
471	3x	table_r <- reactive({
472	3x	req(iv_r()$is_valid())
473	3x	req(decorated_output_q())[["table"]]
474		})
475
476	3x	teal.widgets::table_with_settings_srv(
477	3x	id = "table",
478	3x	table_r = table_r
479		)
480
481	3x	decorated_output_q
482		})
483		}

1		#' `teal` module: Response plot
2		#'
3		#' Generates a response plot for a given `response` and `x` variables.
4		#' This module allows users customize and add annotations to the plot depending
5		#' on the module's arguments.
6		#' It supports showing the counts grouped by other variable facets (by row / column),
7		#' swapping the coordinates, show count annotations and displaying the response plot
8		#' as frequency or density.
9		#'
10		#' @inheritParams teal::module
11		#' @inheritParams shared_params
12		#' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)
13		#' Which variable to use as the response.
14		#' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`.
15		#'
16		#' The `data_extract_spec` must not allow multiple selection in this case.
17		#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
18		#' Specifies which variable to use on the X-axis of the response plot.
19		#' Allow the user to select multiple columns from the `data` allowed in teal.
20		#'
21		#' The `data_extract_spec` must not allow multiple selection in this case.
22		#' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)
23		#' optional specification of the data variable(s) to use for faceting rows.
24		#' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)
25		#' optional specification of the data variable(s) to use for faceting columns.
26		#' @param coord_flip (`logical(1)`)
27		#' Indicates whether to flip coordinates between `x` and `response`.
28		#' The default value is `FALSE` and it will show the `x` variable on the x-axis
29		#' and the `response` variable on the y-axis.
30		#' @param count_labels (`logical(1)`)
31		#' Indicates whether to show count labels.
32		#' Defaults to `TRUE`.
33		#' @param freq (`logical(1)`)
34		#' Indicates whether to display frequency (`TRUE`) or density (`FALSE`).
35		#' Defaults to density (`FALSE`).
36		#'
37		#' @inherit shared_params return
38		#'
39		#' @note For more examples, please see the vignette "Using response plot" via
40		#' `vignette("using-response-plot", package = "teal.modules.general")`.
41		#'
42		#' @section Decorating Module:
43		#'
44		#' This module generates the following objects, which can be modified in place using decorators:
45		#' - `plot` (`ggplot`)
46		#'
47		#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
48		#' The name of this list corresponds to the name of the output to which the decorator is applied.
49		#' See code snippet below:
50		#'
51		#' ```
52		#' tm_g_response(
53		#' ..., # arguments for module
54		#' decorators = list(
55		#' plot = teal_transform_module(...) # applied to the `plot` output
56		#' )
57		#' )
58		#' ```
59		#'
60		#' For additional details and examples of decorators, refer to the vignette
61		#' `vignette("decorate-module-output", package = "teal.modules.general")`.
62		#'
63		#' To learn more please refer to the vignette
64		#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
65		#'
66		#' @inheritSection teal::example_module Reporting
67		#'
68		#' @examplesShinylive
69		#' library(teal.modules.general)
70		#' interactive <- function() TRUE
71		#' {{ next_example }}
72		#' @examples
73		#' # general data example
74		#' data <- teal_data()
75		#' data <- within(data, {
76		#' require(nestcolor)
77		#' mtcars <- mtcars
78		#' for (v in c("cyl", "vs", "am", "gear")) {
79		#' mtcars[[v]] <- as.factor(mtcars[[v]])
80		#' }
81		#' })
82		#'
83		#' app <- init(
84		#' data = data,
85		#' modules = modules(
86		#' tm_g_response(
87		#' label = "Response Plots",
88		#' response = data_extract_spec(
89		#' dataname = "mtcars",
90		#' select = select_spec(
91		#' label = "Select variable:",
92		#' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
93		#' selected = "cyl",
94		#' multiple = FALSE,
95		#' fixed = FALSE
96		#' )
97		#' ),
98		#' x = data_extract_spec(
99		#' dataname = "mtcars",
100		#' select = select_spec(
101		#' label = "Select variable:",
102		#' choices = variable_choices(data[["mtcars"]], c("vs", "am")),
103		#' selected = "vs",
104		#' multiple = FALSE,
105		#' fixed = FALSE
106		#' )
107		#' )
108		#' )
109		#' )
110		#' )
111		#' if (interactive()) {
112		#' shinyApp(app$ui, app$server)
113		#' }
114		#'
115		#' @examplesShinylive
116		#' library(teal.modules.general)
117		#' interactive <- function() TRUE
118		#' {{ next_example }}
119		#' @examples
120		#' # CDISC data example
121		#' data <- teal_data()
122		#' data <- within(data, {
123		#' require(nestcolor)
124		#' ADSL <- teal.data::rADSL
125		#' })
126		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
127		#'
128		#' app <- init(
129		#' data = data,
130		#' modules = modules(
131		#' tm_g_response(
132		#' label = "Response Plots",
133		#' response = data_extract_spec(
134		#' dataname = "ADSL",
135		#' select = select_spec(
136		#' label = "Select variable:",
137		#' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
138		#' selected = "BMRKR2",
139		#' multiple = FALSE,
140		#' fixed = FALSE
141		#' )
142		#' ),
143		#' x = data_extract_spec(
144		#' dataname = "ADSL",
145		#' select = select_spec(
146		#' label = "Select variable:",
147		#' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
148		#' selected = "RACE",
149		#' multiple = FALSE,
150		#' fixed = FALSE
151		#' )
152		#' )
153		#' )
154		#' )
155		#' )
156		#' if (interactive()) {
157		#' shinyApp(app$ui, app$server)
158		#' }
159		#'
160		#' @export
161		#'
162		tm_g_response <- function(label = "Response Plot",
163		response,
164		x,
165		row_facet = NULL,
166		col_facet = NULL,
167		coord_flip = FALSE,
168		count_labels = TRUE,
169		rotate_xaxis_labels = FALSE,
170		freq = FALSE,
171		plot_height = c(600, 400, 5000),
172		plot_width = NULL,
173		ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
174		ggplot2_args = teal.widgets::ggplot2_args(),
175		pre_output = NULL,
176		post_output = NULL,
177		transformators = list(),
178		decorators = list()) {
179	30x	message("Initializing tm_g_response")
180
181		# Normalize the parameters
182	24x	if (inherits(response, "data_extract_spec")) response <- list(response)
183	24x	if (inherits(x, "data_extract_spec")) x <- list(x)
184	!	if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)
185	!	if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)
186
187		# Start of assertions
188	30x	checkmate::assert_string(label)
189
190	29x	checkmate::assert_list(response, types = "data_extract_spec")
191	28x	if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
192	!	stop("'response' should not allow empty values")
193		}
194	28x	assert_single_selection(response)
195
196	27x	checkmate::assert_list(x, types = "data_extract_spec")
197	26x	if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
198	!	stop("'x' should not allow empty values")
199		}
200	26x	assert_single_selection(x)
201
202	25x	checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
203	25x	checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
204	25x	checkmate::assert_flag(coord_flip)
205	25x	checkmate::assert_flag(count_labels)
206	25x	checkmate::assert_flag(rotate_xaxis_labels)
207	25x	checkmate::assert_flag(freq)
208
209	25x	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
210	24x	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
211	23x	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
212	23x	checkmate::assert_numeric(
213	23x	plot_width[1],
214	23x	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
215		)
216
217	22x	ggtheme <- match.arg(ggtheme)
218	21x	checkmate::assert_class(ggplot2_args, "ggplot2_args")
219
220	20x	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
221	20x	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
222
223	20x	assert_decorators(decorators, "plot")
224		# End of assertions
225
226		# Make UI args
227	19x	args <- as.list(environment())
228
229	19x	data_extract_list <- list(
230	19x	response = response,
231	19x	x = x,
232	19x	row_facet = row_facet,
233	19x	col_facet = col_facet
234		)
235
236	19x	ans <- module(
237	19x	label = label,
238	19x	server = srv_g_response,
239	19x	ui = ui_g_response,
240	19x	ui_args = args,
241	19x	server_args = c(
242	19x	data_extract_list,
243	19x	list(
244	19x	plot_height = plot_height,
245	19x	plot_width = plot_width,
246	19x	ggplot2_args = ggplot2_args,
247	19x	decorators = decorators
248		)
249		),
250	19x	transformators = transformators,
251	19x	datanames = teal.transform::get_extract_datanames(data_extract_list)
252		)
253	19x	attr(ans, "teal_bookmarkable") <- TRUE
254	19x	ans
255		}
256
257		# UI function for the response module
258		ui_g_response <- function(id, ...) {
259	!	ns <- NS(id)
260	!	args <- list(...)
261	!	is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet)
262
263	!	teal.widgets::standard_layout(
264	!	output = teal.widgets::white_small_well(
265	!	teal.widgets::plot_with_settings_ui(id = ns("myplot"))
266		),
267	!	encoding = tags$div(
268	!	tags$label("Encodings", class = "text-primary"),
269	!	teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
270	!	teal.transform::data_extract_ui(
271	!	id = ns("response"),
272	!	label = "Response variable",
273	!	data_extract_spec = args$response,
274	!	is_single_dataset = is_single_dataset_value
275		),
276	!	teal.transform::data_extract_ui(
277	!	id = ns("x"),
278	!	label = "X variable",
279	!	data_extract_spec = args$x,
280	!	is_single_dataset = is_single_dataset_value
281		),
282	!	if (!is.null(args$row_facet)) {
283	!	teal.transform::data_extract_ui(
284	!	id = ns("row_facet"),
285	!	label = "Row facetting",
286	!	data_extract_spec = args$row_facet,
287	!	is_single_dataset = is_single_dataset_value
288		)
289		},
290	!	if (!is.null(args$col_facet)) {
291	!	teal.transform::data_extract_ui(
292	!	id = ns("col_facet"),
293	!	label = "Column facetting",
294	!	data_extract_spec = args$col_facet,
295	!	is_single_dataset = is_single_dataset_value
296		)
297		},
298	!	shinyWidgets::radioGroupButtons(
299	!	inputId = ns("freq"),
300	!	label = NULL,
301	!	choices = c("frequency", "density"),
302	!	selected = ifelse(args$freq, "frequency", "density"),
303	!	justified = TRUE
304		),
305	!	ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
306	!	bslib::accordion(
307	!	open = TRUE,
308	!	bslib::accordion_panel(
309	!	title = "Plot settings",
310	!	checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
311	!	checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
312	!	checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
313	!	selectInput(
314	!	inputId = ns("ggtheme"),
315	!	label = "Theme (by ggplot):",
316	!	choices = ggplot_themes,
317	!	selected = args$ggtheme,
318	!	multiple = FALSE
319		)
320		)
321		)
322		),
323	!	pre_output = args$pre_output,
324	!	post_output = args$post_output
325		)
326		}
327
328		# Server function for the response module
329		srv_g_response <- function(id,
330		data,
331		response,
332		x,
333		row_facet,
334		col_facet,
335		plot_height,
336		plot_width,
337		ggplot2_args,
338		decorators) {
339	3x	checkmate::assert_class(data, "reactive")
340	3x	checkmate::assert_class(isolate(data()), "teal_data")
341	3x	moduleServer(id, function(input, output, session) {
342	3x	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
343
344	3x	data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)
345
346	3x	rule_diff <- function(other) {
347	6x	function(value) {
348	!	if (other %in% names(selector_list())) {
349	!	othervalue <- selector_list()[[other]]()[["select"]]
350	!	if (!is.null(othervalue)) {
351	!	if (identical(value, othervalue)) {
352	!	"Row and column facetting variables must be different."
353		}
354		}
355		}
356		}
357		}
358
359	3x	selector_list <- teal.transform::data_extract_multiple_srv(
360	3x	data_extract = data_extract,
361	3x	datasets = data,
362	3x	select_validation_rule = list(
363	3x	response = shinyvalidate::sv_required("Please define a column for the response variable"),
364	3x	x = shinyvalidate::sv_required("Please define a column for X variable"),
365	3x	row_facet = shinyvalidate::compose_rules(
366	3x	shinyvalidate::sv_optional(),
367	3x	~ if (length(.) > 1) "There must be 1 or no row facetting variable.",
368	3x	rule_diff("col_facet")
369		),
370	3x	col_facet = shinyvalidate::compose_rules(
371	3x	shinyvalidate::sv_optional(),
372	3x	~ if (length(.) > 1) "There must be 1 or no column facetting variable.",
373	3x	rule_diff("row_facet")
374		)
375		)
376		)
377
378	3x	iv_r <- reactive({
379	3x	iv <- shinyvalidate::InputValidator$new()
380	3x	iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
381	3x	teal.transform::compose_and_enable_validators(iv, selector_list)
382		})
383
384	3x	anl_merged_input <- teal.transform::merge_expression_srv(
385	3x	selector_list = selector_list,
386	3x	datasets = data
387		)
388
389	3x	qenv <- reactive(
390	3x	teal.code::eval_code(data(), "library(ggplot2);library(dplyr)")
391		)
392
393	3x	anl_merged_q <- reactive({
394	3x	req(anl_merged_input())
395	3x	qenv() %>%
396	3x	teal.code::eval_code(as.expression(anl_merged_input()$expr))
397		})
398
399	3x	merged <- list(
400	3x	anl_input_r = anl_merged_input,
401	3x	anl_q_r = anl_merged_q
402		)
403
404	3x	output_q <- reactive({
405	3x	teal::validate_inputs(iv_r())
406
407	3x	qenv <- merged$anl_q_r()
408	3x	teal.reporter::teal_card(qenv) <-
409	3x	c(
410	3x	teal.reporter::teal_card(qenv),
411	3x	teal.reporter::teal_card("## Module's output(s)")
412		)
413	3x	ANL <- qenv[["ANL"]]
414	3x	resp_var <- as.vector(merged$anl_input_r()$columns_source$response)
415	3x	x <- as.vector(merged$anl_input_r()$columns_source$x)
416
417	3x	validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response."))
418	3x	validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable."))
419	3x	teal::validate_has_data(ANL, 10)
420	3x	teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE)
421
422	3x	row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
423	3x	character(0)
424		} else {
425	!	as.vector(merged$anl_input_r()$columns_source$row_facet)
426		}
427	3x	col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
428	3x	character(0)
429		} else {
430	!	as.vector(merged$anl_input_r()$columns_source$col_facet)
431		}
432
433	3x	freq <- input$freq == "frequency"
434	3x	swap_axes <- input$coord_flip
435	3x	counts <- input$count_labels
436	3x	rotate_xaxis_labels <- input$rotate_xaxis_labels
437	3x	ggtheme <- input$ggtheme
438
439	3x	arg_position <- if (freq) "stack" else "fill"
440
441	3x	rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name)
442	3x	colf <- if (length(col_facet_name) != 0) as.name(col_facet_name)
443	3x	resp_cl <- as.name(resp_var)
444	3x	x_cl <- as.name(x)
445
446	3x	if (swap_axes) {
447	!	qenv <- teal.code::eval_code(
448	!	qenv,
449	!	substitute(
450	!	expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)),
451	!	env = list(x = x, x_cl = x_cl)
452		)
453		)
454		}
455
456	3x	qenv <- teal.code::eval_code(
457	3x	qenv,
458	3x	substitute(
459	3x	expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]),
460	3x	env = list(resp_var = resp_var)
461		)
462		) %>%
463		# rowf and colf will be a NULL if not set by a user
464	3x	teal.code::eval_code(
465	3x	substitute(
466	3x	expr = ANL2 <- ANL %>%
467	3x	dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>%
468	3x	dplyr::summarise(ns = dplyr::n()) %>%
469	3x	dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%
470	3x	dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)),
471	3x	env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf)
472		)
473		) %>%
474	3x	teal.code::eval_code(
475	3x	substitute(
476	3x	expr = ANL3 <- ANL %>%
477	3x	dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%
478	3x	dplyr::summarise(ns = dplyr::n()),
479	3x	env = list(x_cl = x_cl, rowf = rowf, colf = colf)
480		)
481		)
482
483	3x	plot_call <- substitute(
484	3x	expr = ggplot2::ggplot(ANL2, ggplot2::aes(x = x_cl, y = ns)) +
485	3x	ggplot2::geom_bar(ggplot2::aes(fill = resp_cl), stat = "identity", position = arg_position),
486	3x	env = list(
487	3x	x_cl = x_cl,
488	3x	resp_cl = resp_cl,
489	3x	arg_position = arg_position
490		)
491		)
492
493	3x	if (!freq) {
494	3x	plot_call <- substitute(
495	3x	plot_call + ggplot2::expand_limits(y = c(0, 1.1)),
496	3x	env = list(plot_call = plot_call)
497		)
498		}
499
500	3x	if (counts) {
501	3x	plot_call <- substitute(
502	3x	expr = plot_call +
503	3x	ggplot2::geom_text(
504	3x	data = ANL2,
505	3x	ggplot2::aes(label = ns, x = x_cl, y = ns, group = resp_cl),
506	3x	col = "white",
507	3x	vjust = "middle",
508	3x	hjust = "middle",
509	3x	position = position_anl2_value
510		) +
511	3x	ggplot2::geom_text(
512	3x	data = ANL3, ggplot2::aes(label = ns, x = x_cl, y = anl3_y),
513	3x	hjust = hjust_value,
514	3x	vjust = vjust_value,
515	3x	position = position_anl3_value
516		),
517	3x	env = list(
518	3x	plot_call = plot_call,
519	3x	x_cl = x_cl,
520	3x	resp_cl = resp_cl,
521	3x	hjust_value = if (swap_axes) "left" else "middle",
522	3x	vjust_value = if (swap_axes) "middle" else -1,
523	3x	position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length_linter.
524	3x	anl3_y = if (!freq) 1.1 else as.name("ns"),
525	3x	position_anl3_value = if (!freq) "fill" else "stack"
526		)
527		)
528		}
529
530	3x	if (swap_axes) {
531	!	plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call))
532		}
533
534	3x	facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)
535
536	3x	if (!is.null(facet_cl)) {
537	!	plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))
538		}
539
540	3x	dev_ggplot2_args <- teal.widgets::ggplot2_args(
541	3x	labs = list(
542	3x	x = varname_w_label(x, ANL),
543	3x	y = varname_w_label(resp_var, ANL, prefix = "Proportion of "),
544	3x	fill = varname_w_label(resp_var, ANL)
545		),
546	3x	theme = list(legend.position = "bottom")
547		)
548
549	3x	if (rotate_xaxis_labels) {
550	!	dev_ggplot2_args$theme[["axis.text.x"]] <- quote(ggplot2::element_text(angle = 45, hjust = 1))
551		}
552
553	3x	all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
554	3x	user_plot = ggplot2_args,
555	3x	module_plot = dev_ggplot2_args
556		)
557
558	3x	parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
559	3x	all_ggplot2_args,
560	3x	ggtheme = ggtheme
561		)
562
563	3x	plot_call <- substitute(expr = {
564	3x	plot <- plot_call + labs + ggthemes + themes
565	3x	}, env = list(
566	3x	plot_call = plot_call,
567	3x	labs = parsed_ggplot2_args$labs,
568	3x	themes = parsed_ggplot2_args$theme,
569	3x	ggthemes = parsed_ggplot2_args$ggtheme
570		))
571
572	3x	teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Plot")
573	3x	teal.code::eval_code(qenv, plot_call)
574		})
575
576	3x	decorated_output_plot_q <- srv_decorate_teal_data(
577	3x	id = "decorator",
578	3x	data = output_q,
579	3x	decorators = select_decorators(decorators, "plot"),
580	3x	expr = quote(plot)
581		)
582
583	3x	plot_r <- reactive(req(decorated_output_plot_q())[["plot"]])
584
585		# Insert the plot into a plot_with_settings module from teal.widgets
586	3x	pws <- teal.widgets::plot_with_settings_srv(
587	3x	id = "myplot",
588	3x	plot_r = plot_r,
589	3x	height = plot_height,
590	3x	width = plot_width
591		)
592
593	3x	set_chunk_dims(pws, decorated_output_plot_q)
594		})
595		}

1		#' `teal` module: Stack plots of variables and show association with reference variable
2		#'
3		#' Module provides functionality for visualizing the distribution of variables and
4		#' their association with a reference variable.
5		#' It supports configuring the appearance of the plots, including themes and whether to show associations.
6		#'
7		#'
8		#' @note For more examples, please see the vignette "Using association plot" via
9		#' `vignette("using-association-plot", package = "teal.modules.general")`.
10		#'
11		#' @inheritParams teal::module
12		#' @inheritParams shared_params
13		#' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`)
14		#' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)`
15		#' to ensure single selection option.
16		#' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`)
17		#' Variables to be associated with the reference variable.
18		#' @param show_association (`logical`) optional, whether show association of `vars`
19		#' with reference variable. Defaults to `TRUE`.
20		#' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default.
21		#' Default to `"gray"`.
22		#'
23		#' @param ggplot2_args `r roxygen_ggplot2_args_param("Bivariate1", "Bivariate2")`
24		#'
25		#' @inherit shared_params return
26		#'
27		#' @section Decorating Module:
28		#'
29		#' This module generates the following objects, which can be modified in place using decorators:
30		#' - `plot` (`grob` created with [ggplot2::ggplotGrob()])
31		#'
32		#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
33		#' The name of this list corresponds to the name of the output to which the decorator is applied.
34		#' See code snippet below:
35		#'
36		#' ```
37		#' tm_g_association(
38		#' ..., # arguments for module
39		#' decorators = list(
40		#' plot = teal_transform_module(...) # applied to the `plot` output
41		#' )
42		#' )
43		#' ```
44		#'
45		#' For additional details and examples of decorators, refer to the vignette
46		#' `vignette("decorate-module-output", package = "teal.modules.general")`.
47		#'
48		#' To learn more please refer to the vignette
49		#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
50		#'
51		#' @inheritSection teal::example_module Reporting
52		#'
53		#' @examplesShinylive
54		#' library(teal.modules.general)
55		#' interactive <- function() TRUE
56		#' {{ next_example }}
57		#' @examples
58		#' # general data example
59		#' data <- teal_data()
60		#' data <- within(data, {
61		#' require(nestcolor)
62		#' CO2 <- CO2
63		#' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L))))
64		#' CO2[factors] <- lapply(CO2[factors], as.character)
65		#' })
66		#'
67		#' app <- init(
68		#' data = data,
69		#' modules = modules(
70		#' tm_g_association(
71		#' ref = data_extract_spec(
72		#' dataname = "CO2",
73		#' select = select_spec(
74		#' label = "Select variable:",
75		#' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
76		#' selected = "Plant",
77		#' fixed = FALSE
78		#' )
79		#' ),
80		#' vars = data_extract_spec(
81		#' dataname = "CO2",
82		#' select = select_spec(
83		#' label = "Select variables:",
84		#' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
85		#' selected = "Treatment",
86		#' multiple = TRUE,
87		#' fixed = FALSE
88		#' )
89		#' )
90		#' )
91		#' )
92		#' )
93		#' if (interactive()) {
94		#' shinyApp(app$ui, app$server)
95		#' }
96		#'
97		#' @examplesShinylive
98		#' library(teal.modules.general)
99		#' interactive <- function() TRUE
100		#' {{ next_example }}
101		#' @examples
102		#' # CDISC data example
103		#' data <- teal_data()
104		#' data <- within(data, {
105		#' require(nestcolor)
106		#' ADSL <- teal.data::rADSL
107		#' })
108		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
109		#'
110		#' app <- init(
111		#' data = data,
112		#' modules = modules(
113		#' tm_g_association(
114		#' ref = data_extract_spec(
115		#' dataname = "ADSL",
116		#' select = select_spec(
117		#' label = "Select variable:",
118		#' choices = variable_choices(
119		#' data[["ADSL"]],
120		#' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
121		#' ),
122		#' selected = "RACE",
123		#' fixed = FALSE
124		#' )
125		#' ),
126		#' vars = data_extract_spec(
127		#' dataname = "ADSL",
128		#' select = select_spec(
129		#' label = "Select variables:",
130		#' choices = variable_choices(
131		#' data[["ADSL"]],
132		#' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
133		#' ),
134		#' selected = "BMRKR2",
135		#' multiple = TRUE,
136		#' fixed = FALSE
137		#' )
138		#' )
139		#' )
140		#' )
141		#' )
142		#' if (interactive()) {
143		#' shinyApp(app$ui, app$server)
144		#' }
145		#'
146		#' @export
147		#'
148		tm_g_association <- function(label = "Association",
149		ref,
150		vars,
151		show_association = TRUE,
152		plot_height = c(600, 400, 5000),
153		plot_width = NULL,
154		distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint line_length_linter.
155		association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint line_length_linter.
156		pre_output = NULL,
157		post_output = NULL,
158		ggplot2_args = teal.widgets::ggplot2_args(),
159		transformators = list(),
160		decorators = list()) {
161	43x	message("Initializing tm_g_association")
162
163		# Normalize the parameters
164	31x	if (inherits(ref, "data_extract_spec")) ref <- list(ref)
165	31x	if (inherits(vars, "data_extract_spec")) vars <- list(vars)
166	41x	if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
167
168		# Start of assertions
169	43x	checkmate::assert_string(label)
170
171	42x	checkmate::assert_list(ref, types = "data_extract_spec")
172	41x	if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
173	1x	stop("'ref' should not allow multiple selection")
174		}
175
176	40x	checkmate::assert_list(vars, types = "data_extract_spec")
177	39x	checkmate::assert_flag(show_association)
178
179	39x	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
180	38x	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
181	37x	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
182	37x	checkmate::assert_numeric(
183	37x	plot_width[1],
184	37x	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
185		)
186
187	36x	distribution_theme <- match.arg(distribution_theme)
188	35x	association_theme <- match.arg(association_theme)
189
190	34x	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
191	34x	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
192
193	34x	plot_choices <- c("Bivariate1", "Bivariate2")
194	34x	checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
195	34x	checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
196
197	33x	assert_decorators(decorators, "plot")
198		# End of assertions
199
200		# Make UI args
201	32x	args <- as.list(environment())
202
203	32x	data_extract_list <- list(
204	32x	ref = ref,
205	32x	vars = vars
206		)
207
208	32x	ans <- module(
209	32x	label = label,
210	32x	server = srv_tm_g_association,
211	32x	ui = ui_tm_g_association,
212	32x	ui_args = args,
213	32x	server_args = c(
214	32x	data_extract_list,
215	32x	list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators)
216		),
217	32x	transformators = transformators,
218	32x	datanames = teal.transform::get_extract_datanames(data_extract_list)
219		)
220	32x	attr(ans, "teal_bookmarkable") <- TRUE
221	32x	ans
222		}
223
224		# UI function for the association module
225		ui_tm_g_association <- function(id, ...) {
226	!	ns <- NS(id)
227	!	args <- list(...)
228	!	is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars)
229
230	!	teal.widgets::standard_layout(
231	!	output = teal.widgets::white_small_well(
232	!	textOutput(ns("title")),
233	!	tags$br(),
234	!	teal.widgets::plot_with_settings_ui(id = ns("myplot"))
235		),
236	!	encoding = tags$div(
237	!	tags$label("Encodings", class = "text-primary"),
238	!	teal.transform::datanames_input(args[c("ref", "vars")]),
239	!	teal.transform::data_extract_ui(
240	!	id = ns("ref"),
241	!	label = "Reference variable",
242	!	data_extract_spec = args$ref,
243	!	is_single_dataset = is_single_dataset_value
244		),
245	!	teal.transform::data_extract_ui(
246	!	id = ns("vars"),
247	!	label = "Associated variables",
248	!	data_extract_spec = args$vars,
249	!	is_single_dataset = is_single_dataset_value
250		),
251	!	checkboxInput(
252	!	ns("association"),
253	!	"Association with reference variable",
254	!	value = args$show_association
255		),
256	!	checkboxInput(
257	!	ns("show_dist"),
258	!	"Scaled frequencies",
259	!	value = FALSE
260		),
261	!	checkboxInput(
262	!	ns("log_transformation"),
263	!	"Log transformed",
264	!	value = FALSE
265		),
266	!	ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
267	!	bslib::accordion(
268	!	open = TRUE,
269	!	bslib::accordion_panel(
270	!	title = "Plot settings",
271	!	teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
272	!	teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
273	!	checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
274	!	checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
275	!	selectInput(
276	!	inputId = ns("distribution_theme"),
277	!	label = "Distribution theme (by ggplot):",
278	!	choices = ggplot_themes,
279	!	selected = args$distribution_theme,
280	!	multiple = FALSE
281		),
282	!	selectInput(
283	!	inputId = ns("association_theme"),
284	!	label = "Association theme (by ggplot):",
285	!	choices = ggplot_themes,
286	!	selected = args$association_theme,
287	!	multiple = FALSE
288		)
289		)
290		)
291		),
292	!	pre_output = args$pre_output,
293	!	post_output = args$post_output
294		)
295		}
296
297		# Server function for the association module
298		srv_tm_g_association <- function(id,
299		data,
300		ref,
301		vars,
302		plot_height,
303		plot_width,
304		ggplot2_args,
305		decorators) {
306	11x	checkmate::assert_class(data, "reactive")
307	11x	checkmate::assert_class(isolate(data()), "teal_data")
308
309	11x	moduleServer(id, function(input, output, session) {
310	11x	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
311
312	11x	selector_list <- teal.transform::data_extract_multiple_srv(
313	11x	data_extract = list(ref = ref, vars = vars),
314	11x	datasets = data,
315	11x	select_validation_rule = list(
316	11x	ref = shinyvalidate::compose_rules(
317	11x	shinyvalidate::sv_required("A reference variable needs to be selected."),
318	11x	~ if ((.) %in% selector_list()$vars()$select) {
319	!	"Associated variables and reference variable cannot overlap"
320		}
321		),
322	11x	vars = shinyvalidate::compose_rules(
323	11x	shinyvalidate::sv_required("An associated variable needs to be selected."),
324	11x	~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
325	!	"Associated variables and reference variable cannot overlap"
326		}
327		)
328		)
329		)
330
331	11x	iv_r <- reactive({
332	11x	iv <- shinyvalidate::InputValidator$new()
333	11x	teal.transform::compose_and_enable_validators(iv, selector_list)
334		})
335
336	11x	anl_merged_input <- teal.transform::merge_expression_srv(
337	11x	datasets = data,
338	11x	selector_list = selector_list
339		)
340
341	11x	qenv <- reactive({
342	11x	obj <- data()
343	11x	teal.reporter::teal_card(obj) <-
344	11x	c(
345	11x	teal.reporter::teal_card(obj),
346	11x	teal.reporter::teal_card("## Module's output(s)")
347		)
348	11x	teal.code::eval_code(obj, "library(ggplot2);library(dplyr)")
349		})
350	11x	anl_merged_q <- reactive({
351	11x	req(anl_merged_input())
352	11x	qenv() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr))
353		})
354
355	11x	merged <- list(
356	11x	anl_input_r = anl_merged_input,
357	11x	anl_q_r = anl_merged_q
358		)
359
360	11x	output_q <- reactive({
361	11x	teal::validate_inputs(iv_r())
362
363	11x	ANL <- merged$anl_q_r()[["ANL"]]
364	11x	teal::validate_has_data(ANL, 3)
365
366	11x	vars_names <- merged$anl_input_r()$columns_source$vars
367
368	11x	ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)
369	11x	association <- input$association
370	11x	show_dist <- input$show_dist
371	11x	log_transformation <- input$log_transformation
372	11x	rotate_xaxis_labels <- input$rotate_xaxis_labels
373	11x	swap_axes <- input$swap_axes
374	11x	distribution_theme <- input$distribution_theme
375	11x	association_theme <- input$association_theme
376
377	11x	is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))
378	11x	if (is_scatterplot) {
379	2x	shinyjs::show("alpha")
380	2x	shinyjs::show("size")
381	2x	alpha <- input$alpha
382	2x	size <- input$size
383		} else {
384	9x	shinyjs::hide("alpha")
385	9x	shinyjs::hide("size")
386	9x	alpha <- 0.5
387	9x	size <- 2
388		}
389
390	11x	teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)
391
392		# reference
393	11x	ref_class <- class(ANL[[ref_name]])[1]
394	11x	if (is.numeric(ANL[[ref_name]]) && log_transformation) {
395		# works for both integers and doubles
396	1x	ref_cl_name <- call("log", as.name(ref_name))
397	1x	ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")
398		} else {
399		# silently ignore when non-numeric even if `log` is selected because some
400		# variables may be numeric and others not
401	10x	ref_cl_name <- as.name(ref_name)
402	10x	ref_cl_lbl <- varname_w_label(ref_name, ANL)
403		}
404
405	11x	user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
406	11x	user_plot = ggplot2_args[["Bivariate1"]],
407	11x	user_default = ggplot2_args$default
408		)
409
410	11x	ref_call <- bivariate_plot_call(
411	11x	data_name = "ANL",
412	11x	x = ref_cl_name,
413	11x	x_class = ref_class,
414	11x	x_label = ref_cl_lbl,
415	11x	freq = !show_dist,
416	11x	theme = distribution_theme,
417	11x	rotate_xaxis_labels = rotate_xaxis_labels,
418	11x	swap_axes = FALSE,
419	11x	size = size,
420	11x	alpha = alpha,
421	11x	ggplot2_args = user_ggplot2_args
422		)
423
424		# association
425	11x	ref_class_cov <- ifelse(association, ref_class, "NULL")
426
427	11x	var_calls <- lapply(vars_names, function(var_i) {
428	15x	var_class <- class(ANL[[var_i]])[1]
429	15x	if (is.numeric(ANL[[var_i]]) && log_transformation) {
430		# works for both integers and doubles
431	2x	var_cl_name <- call("log", as.name(var_i))
432	2x	var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")
433		} else {
434		# silently ignore when non-numeric even if `log` is selected because some
435		# variables may be numeric and others not
436	13x	var_cl_name <- as.name(var_i)
437	13x	var_cl_lbl <- varname_w_label(var_i, ANL)
438		}
439
440	15x	user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
441	15x	user_plot = ggplot2_args[["Bivariate2"]],
442	15x	user_default = ggplot2_args$default
443		)
444
445	15x	bivariate_plot_call(
446	15x	data_name = "ANL",
447	15x	x = ref_cl_name,
448	15x	y = var_cl_name,
449	15x	x_class = ref_class_cov,
450	15x	y_class = var_class,
451	15x	x_label = ref_cl_lbl,
452	15x	y_label = var_cl_lbl,
453	15x	theme = association_theme,
454	15x	freq = !show_dist,
455	15x	rotate_xaxis_labels = rotate_xaxis_labels,
456	15x	swap_axes = swap_axes,
457	15x	alpha = alpha,
458	15x	size = size,
459	15x	ggplot2_args = user_ggplot2_args
460		)
461		})
462
463		# helper function to format variable name
464	11x	format_varnames <- function(x) {
465	15x	if (is.numeric(ANL[[x]]) && log_transformation) {
466	2x	varname_w_label(x, ANL, prefix = "Log of ")
467		} else {
468	13x	varname_w_label(x, ANL)
469		}
470		}
471	11x	new_title <-
472	11x	if (association) {
473	10x	switch(as.character(length(vars_names)),
474	!	"0" = sprintf("Value distribution for %s", ref_cl_lbl),
475	6x	"1" = sprintf(
476	6x	"Association between %s and %s",
477	6x	ref_cl_lbl,
478	6x	format_varnames(vars_names)
479		),
480	4x	sprintf(
481	4x	"Associations between %s and: %s",
482	4x	ref_cl_lbl,
483	4x	paste(lapply(vars_names, format_varnames), collapse = ", ")
484		)
485		)
486		} else {
487	1x	switch(as.character(length(vars_names)),
488	!	"0" = sprintf("Value distribution for %s", ref_cl_lbl),
489	1x	sprintf(
490	1x	"Value distributions for %s and %s",
491	1x	ref_cl_lbl,
492	1x	paste(lapply(vars_names, format_varnames), collapse = ", ")
493		)
494		)
495		}
496	11x	obj <- merged$anl_q_r()
497	11x	teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "### Plot")
498	11x	teal.code::eval_code(
499	11x	obj,
500	11x	substitute(
501	11x	expr = title <- new_title,
502	11x	env = list(new_title = new_title)
503		)
504		) %>%
505	11x	teal.code::eval_code(
506	11x	substitute(
507	11x	expr = {
508	11x	plots <- plot_calls
509	11x	plot <- gridExtra::arrangeGrob(grobs = plots, ncol = 1)
510		},
511	11x	env = list(
512	11x	plot_calls = do.call(
513	11x	"call",
514	11x	c(list("list", ref_call), unname(var_calls)),
515	11x	quote = TRUE
516		)
517		)
518		)
519		)
520		})
521
522	11x	decorated_output_grob_q <- srv_decorate_teal_data(
523	11x	id = "decorator",
524	11x	data = output_q,
525	11x	decorators = select_decorators(decorators, "plot"),
526	11x	expr = quote({
527	11x	grid::grid.newpage()
528	11x	grid::grid.draw(plot)
529		})
530		)
531
532	11x	plot_r <- reactive({
533	11x	req(iv_r()$is_valid())
534	11x	req(decorated_output_grob_q())[["plot"]]
535		})
536
537	11x	pws <- teal.widgets::plot_with_settings_srv(
538	11x	id = "myplot",
539	11x	plot_r = plot_r,
540	11x	height = plot_height,
541	11x	width = plot_width
542		)
543
544	11x	output$title <- renderText(output_q()[["title"]])
545
546	11x	set_chunk_dims(pws, decorated_output_grob_q)
547		})
548		}

1		# minimal implementation of ggplot2 mosaic after ggmosaic was archived in CRAN
2		#
3		# This was heavily inspired by github.com/haleyjeppson/ggmosaic package but
4		# simplified to only support 2 categorical variables
5
6		#' Mosaic Rectangles Layer for ggplot2
7		#'
8		#' Adds a mosaic-style rectangles layer to a ggplot, visualizing the
9		#' joint distribution of categorical variables.
10		#' Each rectangle's size reflects the proportion of observations for
11		#' combinations of `x` and `fill`.
12		#'
13		#' @param mapping Set of aesthetic mappings created by `aes()`. Must specify `x` and `fill`.
14		#' @param data The data to be displayed in this layer.
15		#' @param stat The statistical transformation to use on the data. Defaults to `"rects"`.
16		#' @param position Position adjustment. Defaults to `"identity"`.
17		#' @param ... Other arguments passed to `layer()`.
18		#' @param na.rm Logical. Should missing values be removed?
19		#' @param show.legend Logical. Should this layer be included in the legends?
20		#' @param inherit.aes Logical. If `FALSE`, overrides default aesthetics.
21		#'
22		#' @return A ggplot2 layer that adds mosaic rectangles to the plot.
23		#'
24		#' @examples
25		#' df <- data.frame(RACE = c("Black", "White", "Black", "Asian"), SEX = c("M", "M", "F", "F"))
26		#' library(ggplot2)
27		#' ggplot(df) +
28		#' geom_mosaic(aes(x = RACE, fill = SEX))
29		#' @export
30		geom_mosaic <- function(mapping = NULL, data = NULL,
31		stat = "mosaic", position = "identity",
32		...,
33		na.rm = FALSE, # nolint: object_name_linter.
34		show.legend = TRUE, # nolint: object_name_linter.
35		inherit.aes = TRUE) { # nolint: object_name_linter.
36
37	9x	aes_x <- mapping$x
38	9x	if (!is.null(aes_x)) {
39	9x	aes_x <- list(rlang::quo_get_expr(mapping$x))
40	9x	var_x <- paste0("x__", as.character(aes_x))
41	9x	mapping[[var_x]] <- mapping$x
42		}
43
44	9x	aes_fill <- mapping$fill
45	9x	if (!is.null(aes_fill)) {
46	9x	aes_fill <- rlang::quo_text(mapping$fill)
47		}
48
49	9x	mapping$x <- structure(1L)
50
51	9x	layer <- ggplot2::layer(
52	9x	geom = GeomMosaic,
53	9x	stat = "mosaic",
54	9x	data = data,
55	9x	mapping = mapping,
56	9x	position = position,
57	9x	show.legend = show.legend,
58	9x	inherit.aes = inherit.aes,
59	9x	check.aes = FALSE,
60	9x	params = list(na.rm = na.rm, ...)
61		)
62	9x	list(layer, .scale_x_mosaic())
63		}
64
65		#' @keywords internal
66		GeomMosaic <- ggplot2::ggproto( # nolint: object_name_linter.
67		"GeomMosaic", ggplot2::GeomRect,
68		default_aes = ggplot2::aes(
69		colour = NA, linewidth = 0.5, linetype = 1, alpha = 1, fill = "grey30"
70		),
71		draw_panel = function(data, panel_params, coord) {
72		if (all(is.na(data$colour))) data$colour <- scales::alpha(data$fill, data$alpha)
73		ggplot2::GeomRect$draw_panel(data, panel_params, coord)
74		},
75		required_aes = c("xmin", "xmax", "ymin", "ymax")
76		)
77
78		#' @keywords internal
79		StatMosaic <- ggplot2::ggproto( # nolint: object_name_linter.
80		"StatMosaic", ggplot2::Stat,
81		required_aes = c("x", "fill"),
82		compute_group = function(data, scales) data,
83		compute_panel = function(data, scales) {
84		data$x <- data[, grepl("x__", colnames(data))]
85		result <- .calculate_coordinates(data)
86
87		results_non_zero <- result[result$.n != 0, ]
88		breaks <- unique(with(results_non_zero, (xmin + xmax) / 2))
89		labels <- unique(results_non_zero$x)
90		result$x <- list(list2env(list(breaks = breaks[breaks != 0], labels = labels[breaks != 0])))
91
92		result$group <- 1
93		result$PANEL <- unique(data$PANEL)
94		result
95		}
96		)
97
98		#' Determining scales for mosaics
99		#'
100		#' @param breaks,labels,minor_breaks One of:
101		#' - `NULL` for no breaks / labels.
102		#' - [ggplot2::waiver()] for the default breaks / labels computed by the scale.
103		#' - A numeric / character vector giving the positions of the breaks / labels.
104		#' - A function.
105		#' See [ggplot2::scale_x_continuous()] for more details.
106		#' @param na.value The value to be used for `NA` values.
107		#' @param position For position scales, The position of the axis.
108		#' left or right for y axes, top or bottom for x axes.
109		#' @param ... other arguments passed to `continuous_scale()`.
110		#' @keywords internal
111		.scale_x_mosaic <- function(breaks = unique,
112		minor_breaks = NULL,
113		labels = unique,
114		na.value = NA_real_, # nolint: object_name_linter.
115		position = "bottom",
116		...) {
117	9x	ggplot2::continuous_scale(
118	9x	aesthetics = c(
119	9x	"x", "xmin", "xmax", "xend", "xintercept", "xmin_final", "xmax_final",
120	9x	"xlower", "xmiddle", "xupper"
121		),
122	9x	palette = identity,
123	9x	breaks = breaks,
124	9x	minor_breaks = minor_breaks,
125	9x	labels = labels,
126	9x	na.value = na.value,
127	9x	position = position,
128	9x	super = ScaleContinuousMosaic, ,
129	9x	guide = ggplot2::waiver(),
130		...
131		)
132		}
133
134		#' @keywords internal
135		ScaleContinuousMosaic <- ggplot2::ggproto( # nolint: object_name_linter.
136		"ScaleContinuousMosaic", ggplot2::ScaleContinuousPosition,
137		train = function(self, x) {
138		if (length(x) == 0) {
139		return()
140		}
141		if (is.list(x)) {
142		scale_x <- x[[1]]
143		# re-assign the scale values now that we have the information - but only if necessary
144		if (is.function(self$breaks)) self$breaks <- scale_x$breaks
145		if (is.function(self$labels)) self$labels <- as.vector(scale_x$labels)
146		return(NULL)
147		}
148		if (is_discrete(x)) {
149		self$range$train(x = c(0, 1))
150		return(NULL)
151		}
152		self$range$train(x, call = self$call)
153		},
154		map = function(self, x, limits = self$get_limits()) {
155		if (is_discrete(x)) {
156		return(x)
157		}
158		if (is.list(x)) {
159		return(0)
160		} # need a number
161		scaled <- as.numeric(self$oob(x, limits))
162		ifelse(!is.na(scaled), scaled, self$na.value)
163		},
164		dimension = function(self, expand = c(0, 0)) c(-0.05, 1.05)
165		)
166
167		#' @noRd
168	63x	is_discrete <- function(x) is.factor(x) \|\| is.character(x) \|\| is.logical(x)
169
170		#' @describeIn geom_mosaic
171		#' Computes the coordinates for rectangles in a mosaic plot based
172		#' on combinations of `x` and `fill` variables.
173		#' For each unique `x` and `fill`, calculates the proportional
174		#' widths and heights, stacking rectangles within each `x` group.
175		#'
176		#' ### Value
177		#'
178		#' A data frame with columns: `x`, `fill`, `xmin`, `xmax`, `ymin`, `ymax`,
179		#' representing the position and size of each rectangle.
180		#'
181		#' @keywords internal
182		.calculate_coordinates <- function(data) {
183		# Example: compute rectangles from x and y
184	9x	result <- data \|>
185		# Count combinations of X and Y
186	9x	dplyr::count(.data$x, .data$fill, .drop = FALSE) \|>
187		# Compute total for each X group
188	9x	dplyr::mutate(
189	9x	.by = .data$x,
190	9x	x_total = sum(.data$n),
191	9x	prop = .data$n / .data$x_total,
192	9x	prop = dplyr::if_else(is.nan(.data$prop), 0, .data$prop)
193		) \|>
194	9x	dplyr::arrange(dplyr::desc(.data$x_total), .data$x, .data$fill) \|>
195		# Compute total sample size to turn counts into widths
196	9x	dplyr::mutate(
197	9x	N_total = dplyr::n(),
198	9x	x_width = .data$x_total / .data$N_total
199		) \|>
200		# Convert counts to x widths
201	9x	dplyr::mutate(
202	9x	.by = .data$x,
203	9x	x_width_last = dplyr::if_else(dplyr::row_number() == dplyr::n(), .data$x_width, 0)
204		) \|>
205		# Compute x-min/x-max for each group
206	9x	dplyr::mutate(
207	9x	xmin = cumsum(dplyr::lag(.data$x_width_last, default = 0)),
208	9x	xmax = .data$xmin + .data$x_width
209		) \|>
210		# Compute y-min/y-max for stacked proportions
211	9x	dplyr::mutate(
212	9x	.by = .data$x,
213	9x	ymin = c(0, utils::head(cumsum(.data$prop), -1)),
214	9x	ymax = cumsum(.data$prop)
215		) \|>
216	9x	dplyr::mutate(
217	9x	xmin = .data$xmin / max(.data$xmax),
218	9x	xmax = .data$xmax / max(.data$xmax),
219	9x	xmin = dplyr::if_else(.data$n == 0, 0, .data$xmin + 0.005),
220	9x	xmax = dplyr::if_else(.data$n == 0, 0, .data$xmax - 0.005),
221	9x	ymin = dplyr::if_else(.data$n == 0, 0, .data$ymin + 0.005),
222	9x	ymax = dplyr::if_else(.data$n == 0, 0, .data$ymax - 0.005)
223		) \|>
224	9x	dplyr::select(.data$x, .data$fill, .data$xmin, .data$xmax, .data$ymin, .data$ymax, .n = .data$n)
225	9x	result
226		}

1		#' `teal` module: Front page
2		#'
3		#' Creates a simple front page for `teal` applications, displaying
4		#' introductory text, tables, additional `html` or `shiny` tags, and footnotes.
5		#'
6		#' @inheritParams teal::module
7		#' @param header_text (`character` vector) text to be shown at the top of the module, for each
8		#' element, if named the name is shown first in bold as a header followed by the value. The first
9		#' element's header is displayed larger than the others.
10		#' @param tables (`named list` of `data.frame`s) tables to be shown in the module.
11		#' @param additional_tags (`shiny.tag.list` or `html`) additional `shiny` tags or `html` to be included after the table,
12		#' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`,
13		#' `HTML("html text here")`.
14		#' @param footnotes (`character` vector) of text to be shown at the bottom of the module, for each
15		#' element, if named the name is shown first in bold, followed by the value.
16		#' @param show_metadata (`logical`) `r lifecycle::badge("deprecated")` indicating
17		#' whether the metadata of the datasets be available on the module.
18		#' Metadata shown automatically when `datanames` set.
19		#' @inheritParams tm_variable_browser
20		#'
21		#' @inherit shared_params return
22		#'
23		#' @examplesShinylive
24		#' library(teal.modules.general)
25		#' interactive <- function() TRUE
26		#' {{ next_example }}
27		#' @examples
28		#' data <- teal_data()
29		#' data <- within(data, {
30		#' require(nestcolor)
31		#' ADSL <- teal.data::rADSL
32		#' attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")
33		#' })
34		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
35		#'
36		#' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
37		#' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
38		#' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
39		#'
40		#' table_input <- list(
41		#' "Table 1" = table_1,
42		#' "Table 2" = table_2,
43		#' "Table 3" = table_3
44		#' )
45		#'
46		#' app <- init(
47		#' data = data,
48		#' modules = modules(
49		#' tm_front_page(
50		#' header_text = c(
51		#' "Important information" = "It can go here.",
52		#' "Other information" = "Can go here."
53		#' ),
54		#' tables = table_input,
55		#' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
56		#' footnotes = c("X" = "is the first footnote", "Y is the second footnote")
57		#' )
58		#' )
59		#' ) \|>
60		#' modify_header(tags$h1("Sample Application")) \|>
61		#' modify_footer(tags$p("Application footer"))
62		#'
63		#' if (interactive()) {
64		#' shinyApp(app$ui, app$server)
65		#' }
66		#'
67		#' @export
68		#'
69		tm_front_page <- function(label = "Front page",
70		header_text = character(0),
71		tables = list(),
72		additional_tags = tagList(),
73		footnotes = character(0),
74		show_metadata = deprecated(),
75		datanames = if (missing(show_metadata)) NULL else "all",
76		transformators = list()) {
77	25x	message("Initializing tm_front_page")
78
79		# Start of assertions
80	25x	checkmate::assert_string(label)
81	24x	checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE)
82	22x	checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE)
83	19x	checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
84	17x	checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE)
85	15x	if (!missing(show_metadata)) {
86	1x	lifecycle::deprecate_stop(
87	1x	when = "0.4.0",
88	1x	what = "tm_front_page(show_metadata)",
89	1x	with = "tm_front_page(datanames)",
90	1x	details = c(
91	1x	"With `datanames` you can select which datasets are displayed.",
92	1x	i = "Use `tm_front_page(datanames = 'all')` to keep the previous behavior and avoid this warning."
93		)
94		)
95		}
96	14x	checkmate::assert_character(datanames, min.len = 0, min.chars = 1, null.ok = TRUE)
97
98		# End of assertions
99
100		# Make UI args
101	12x	args <- as.list(environment())
102
103	12x	ans <- module(
104	12x	label = label,
105	12x	server = srv_front_page,
106	12x	ui = ui_front_page,
107	12x	ui_args = args,
108	12x	server_args = list(tables = tables),
109	12x	datanames = datanames, ,
110	12x	transformators = transformators
111		)
112	11x	attr(ans, "teal_bookmarkable") <- TRUE
113	11x	ans
114		}
115
116		# UI function for the front page module
117		ui_front_page <- function(id, ...) {
118	5x	args <- list(...)
119	5x	ns <- NS(id)
120
121	5x	tagList(
122	5x	tags$div(
123	5x	id = "front_page_content",
124	5x	style = "margin-left: 2rem;",
125	5x	tags$div(
126	5x	id = "front_page_headers",
127	5x	get_header_tags(args$header_text)
128		),
129	5x	tags$div(
130	5x	id = "front_page_tables",
131	5x	style = "margin-left: 2rem;",
132	5x	get_table_tags(args$tables, ns)
133		),
134	5x	tags$div(
135	5x	id = "front_page_custom_html",
136	5x	style = "margin-left: 2rem;",
137	5x	args$additional_tags
138		),
139	5x	if (length(args$datanames) > 0L) {
140	1x	tags$div(
141	1x	id = "front_page_metabutton",
142	1x	style = "margin: 1rem;",
143	1x	actionButton(ns("metadata_button"), "Show metadata")
144		)
145		},
146	5x	tags$footer(
147	5x	class = "small",
148	5x	get_footer_tags(args$footnotes)
149		)
150		)
151		)
152		}
153
154		# Server function for the front page module
155		srv_front_page <- function(id, data, tables) {
156	3x	checkmate::assert_class(data, "reactive")
157	3x	checkmate::assert_class(isolate(data()), "teal_data")
158	3x	moduleServer(id, function(input, output, session) {
159	3x	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
160
161	3x	ns <- session$ns
162
163	3x	setBookmarkExclude("metadata_button")
164
165	3x	lapply(seq_along(tables), function(idx) {
166	1x	output[[paste0("table_", idx)]] <- renderTable(
167	1x	tables[[idx]],
168	1x	bordered = TRUE,
169	1x	caption = names(tables)[idx],
170	1x	caption.placement = "top"
171		)
172		})
173	3x	if (length(isolate(names(data()))) > 0L) {
174	2x	observeEvent(
175	2x	input$metadata_button, showModal(
176	2x	modalDialog(
177	2x	title = "Metadata",
178	2x	dataTableOutput(ns("metadata_table")),
179	2x	size = "l",
180	2x	easyClose = TRUE
181		)
182		)
183		)
184
185	2x	metadata_data_frame <- reactive({
186	2x	datanames <- names(data())
187	2x	convert_metadata_to_dataframe(
188	2x	lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")),
189	2x	datanames
190		)
191		})
192
193	2x	output$metadata_table <- DT::renderDT({
194	2x	validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata"))
195	1x	metadata_data_frame()
196		})
197		}
198		})
199		}
200
201		## utils functions
202
203		get_header_tags <- function(header_text) {
204	5x	if (length(header_text) == 0) {
205	4x	return(list())
206		}
207
208	1x	get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
209	1x	tagList(
210	1x	tags$div(
211	1x	if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text),
212	1x	tags$p(p_text)
213		)
214		)
215		}
216
217	1x	header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3)
218	1x	c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1)))
219		}
220
221		get_table_tags <- function(tables, ns) {
222	5x	if (length(tables) == 0) {
223	4x	return(list())
224		}
225	1x	table_tags <- c(lapply(seq_along(tables), function(idx) {
226	1x	list(
227	1x	tableOutput(ns(paste0("table_", idx)))
228		)
229		}))
230	1x	table_tags
231		}
232
233		get_footer_tags <- function(footnotes) {
234	5x	if (length(footnotes) == 0) {
235	4x	return(list())
236		}
237	1x	bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
238	1x	footnote_tags <- mapply(function(bold_text, value) {
239	1x	list(
240	1x	tags$div(
241	1x	tags$b(bold_text),
242	1x	value,
243	1x	tags$br()
244		)
245		)
246	1x	}, bold_text = bold_texts, value = footnotes)
247		}
248
249		# take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata())
250		# and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
251		# which are, the Dataset the metadata came from, the metadata's name and value
252		convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
253	6x	output <- mapply(function(metadata, dataname) {
254	9x	if (is.null(metadata)) {
255	4x	return(data.frame(Dataset = character(0), Name = character(0), Value = character(0)))
256		}
257	5x	data.frame(
258	5x	Dataset = dataname,
259	5x	Name = names(metadata),
260	5x	Value = unname(unlist(lapply(metadata, as.character)))
261		)
262	6x	}, raw_metadata, datanames, SIMPLIFY = FALSE)
263	6x	do.call(rbind, output)
264		}

1		#' `teal` module: Scatterplot matrix
2		#'
3		#' Generates a scatterplot matrix from selected `variables` from datasets.
4		#' Each plot within the matrix represents the relationship between two variables,
5		#' providing the overview of correlations and distributions across selected data.
6		#'
7		#' @note For more examples, please see the vignette "Using scatterplot matrix" via
8		#' `vignette("using-scatterplot-matrix", package = "teal.modules.general")`.
9		#'
10		#' @inheritParams teal::module
11		#' @inheritParams tm_g_scatterplot
12		#' @inheritParams shared_params
13		#'
14		#' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)
15		#' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of
16		#' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be
17		#' rendered according to selection order.
18		#'
19		#' @inherit shared_params return
20		#'
21		#' @section Decorating Module:
22		#'
23		#' This module generates the following objects, which can be modified in place using decorators:
24		#' - `plot` (`trellis` - output of `lattice::splom`)
25		#'
26		#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
27		#' The name of this list corresponds to the name of the output to which the decorator is applied.
28		#' See code snippet below:
29		#'
30		#' ```
31		#' tm_g_scatterplotmatrix(
32		#' ..., # arguments for module
33		#' decorators = list(
34		#' plot = teal_transform_module(...) # applied to the `plot` output
35		#' )
36		#' )
37		#' ```
38		#'
39		#' For additional details and examples of decorators, refer to the vignette
40		#' `vignette("decorate-module-output", package = "teal.modules.general")`.
41		#'
42		#' To learn more please refer to the vignette
43		#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
44		#'
45		#' @inheritSection teal::example_module Reporting
46		#'
47		#' @examplesShinylive
48		#' library(teal.modules.general)
49		#' interactive <- function() TRUE
50		#' {{ next_example }}
51		#' @examples
52		#' # general data example
53		#' data <- teal_data()
54		#' data <- within(data, {
55		#' countries <- data.frame(
56		#' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
57		#' government = factor(
58		#' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2),
59		#' labels = c("Monarchy", "Republic")
60		#' ),
61		#' language_family = factor(
62		#' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1),
63		#' labels = c("Germanic", "Hellenic", "Romance")
64		#' ),
65		#' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9),
66		#' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83),
67		#' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4),
68		#' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4)
69		#' )
70		#' sales <- data.frame(
71		#' id = 1:50,
72		#' country_id = sample(
73		#' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
74		#' size = 50,
75		#' replace = TRUE
76		#' ),
77		#' year = sort(sample(2010:2020, 50, replace = TRUE)),
78		#' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
79		#' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE),
80		#' quantity = rnorm(50, 100, 20),
81		#' costs = rnorm(50, 80, 20),
82		#' profit = rnorm(50, 20, 10)
83		#' )
84		#' })
85		#' join_keys(data) <- join_keys(
86		#' join_key("countries", "countries", "id"),
87		#' join_key("sales", "sales", "id"),
88		#' join_key("countries", "sales", c("id" = "country_id"))
89		#' )
90		#'
91		#' app <- init(
92		#' data = data,
93		#' modules = modules(
94		#' tm_g_scatterplotmatrix(
95		#' label = "Scatterplot matrix",
96		#' variables = list(
97		#' data_extract_spec(
98		#' dataname = "countries",
99		#' select = select_spec(
100		#' label = "Select variables:",
101		#' choices = variable_choices(data[["countries"]]),
102		#' selected = c("area", "gdp", "debt"),
103		#' multiple = TRUE,
104		#' ordered = TRUE,
105		#' fixed = FALSE
106		#' )
107		#' ),
108		#' data_extract_spec(
109		#' dataname = "sales",
110		#' filter = filter_spec(
111		#' label = "Select variable:",
112		#' vars = "country_id",
113		#' choices = value_choices(data[["sales"]], "country_id"),
114		#' selected = c("DE", "FR", "IT", "PT", "GR", "NL", "BE", "LU", "AT"),
115		#' multiple = TRUE
116		#' ),
117		#' select = select_spec(
118		#' label = "Select variables:",
119		#' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
120		#' selected = c("quantity", "costs", "profit"),
121		#' multiple = TRUE,
122		#' ordered = TRUE,
123		#' fixed = FALSE
124		#' )
125		#' )
126		#' )
127		#' )
128		#' )
129		#' )
130		#' if (interactive()) {
131		#' shinyApp(app$ui, app$server)
132		#' }
133		#'
134		#' @examplesShinylive
135		#' library(teal.modules.general)
136		#' interactive <- function() TRUE
137		#' {{ next_example }}
138		#' @examples
139		#' # CDISC data example
140		#' data <- teal_data()
141		#' data <- within(data, {
142		#' ADSL <- teal.data::rADSL
143		#' ADRS <- teal.data::rADRS
144		#' })
145		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
146		#'
147		#' app <- init(
148		#' data = data,
149		#' modules = modules(
150		#' tm_g_scatterplotmatrix(
151		#' label = "Scatterplot matrix",
152		#' variables = list(
153		#' data_extract_spec(
154		#' dataname = "ADSL",
155		#' select = select_spec(
156		#' label = "Select variables:",
157		#' choices = variable_choices(data[["ADSL"]]),
158		#' selected = c("AGE", "RACE", "SEX"),
159		#' multiple = TRUE,
160		#' ordered = TRUE,
161		#' fixed = FALSE
162		#' )
163		#' ),
164		#' data_extract_spec(
165		#' dataname = "ADRS",
166		#' filter = filter_spec(
167		#' label = "Select endpoints:",
168		#' vars = c("PARAMCD", "AVISIT"),
169		#' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
170		#' selected = "INVET - END OF INDUCTION",
171		#' multiple = TRUE
172		#' ),
173		#' select = select_spec(
174		#' label = "Select variables:",
175		#' choices = variable_choices(data[["ADRS"]]),
176		#' selected = c("AGE", "AVAL", "ADY"),
177		#' multiple = TRUE,
178		#' ordered = TRUE,
179		#' fixed = FALSE
180		#' )
181		#' )
182		#' )
183		#' )
184		#' )
185		#' )
186		#' if (interactive()) {
187		#' shinyApp(app$ui, app$server)
188		#' }
189		#'
190		#' @export
191		#'
192		tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",
193		variables,
194		plot_height = c(600, 200, 2000),
195		plot_width = NULL,
196		pre_output = NULL,
197		post_output = NULL,
198		transformators = list(),
199		decorators = list()) {
200	15x	message("Initializing tm_g_scatterplotmatrix")
201
202		# Normalize the parameters
203	10x	if (inherits(variables, "data_extract_spec")) variables <- list(variables)
204
205		# Start of assertions
206	15x	checkmate::assert_string(label)
207	14x	checkmate::assert_list(variables, types = "data_extract_spec")
208
209	13x	checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
210	12x	checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
211	11x	checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
212	11x	checkmate::assert_numeric(
213	11x	plot_width[1],
214	11x	lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
215		)
216
217	10x	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
218	10x	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
219
220	10x	assert_decorators(decorators, "plot")
221		# End of assertions
222
223		# Make UI args
224	9x	args <- as.list(environment())
225
226	9x	ans <- module(
227	9x	label = label,
228	9x	server = srv_g_scatterplotmatrix,
229	9x	ui = ui_g_scatterplotmatrix,
230	9x	ui_args = args,
231	9x	server_args = list(
232	9x	variables = variables,
233	9x	plot_height = plot_height,
234	9x	plot_width = plot_width,
235	9x	decorators = decorators
236		),
237	9x	transformators = transformators,
238	9x	datanames = teal.transform::get_extract_datanames(variables)
239		)
240	9x	attr(ans, "teal_bookmarkable") <- TRUE
241	9x	ans
242		}
243
244		# UI function for the scatterplot matrix module
245		ui_g_scatterplotmatrix <- function(id, ...) {
246	!	args <- list(...)
247	!	is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)
248	!	ns <- NS(id)
249	!	teal.widgets::standard_layout(
250	!	output = teal.widgets::white_small_well(
251	!	textOutput(ns("message")),
252	!	tags$br(),
253	!	teal.widgets::plot_with_settings_ui(id = ns("myplot"))
254		),
255	!	encoding = tags$div(
256	!	tags$label("Encodings", class = "text-primary"),
257	!	teal.transform::datanames_input(args$variables),
258	!	teal.transform::data_extract_ui(
259	!	id = ns("variables"),
260	!	label = "Variables",
261	!	data_extract_spec = args$variables,
262	!	is_single_dataset = is_single_dataset_value
263		),
264	!	tags$hr(),
265	!	ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
266	!	bslib::accordion(
267	!	open = TRUE,
268	!	bslib::accordion_panel(
269	!	title = "Plot settings",
270	!	sliderInput(
271	!	ns("alpha"), "Opacity:",
272	!	min = 0, max = 1,
273	!	step = .05, value = .5, ticks = FALSE
274		),
275	!	sliderInput(
276	!	ns("cex"), "Points size:",
277	!	min = 0.2, max = 3,
278	!	step = .05, value = .65, ticks = FALSE
279		),
280	!	checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
281	!	radioButtons(
282	!	ns("cor_method"), "Select Correlation Method",
283	!	choiceNames = c("Pearson", "Kendall", "Spearman"),
284	!	choiceValues = c("pearson", "kendall", "spearman"),
285	!	inline = TRUE
286		),
287	!	checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
288		)
289		)
290		),
291	!	pre_output = args$pre_output,
292	!	post_output = args$post_output
293		)
294		}
295
296		# Server function for the scatterplot matrix module
297		srv_g_scatterplotmatrix <- function(id,
298		data,
299		variables,
300		plot_height,
301		plot_width,
302		decorators) {
303	2x	checkmate::assert_class(data, "reactive")
304	2x	checkmate::assert_class(isolate(data()), "teal_data")
305	2x	moduleServer(id, function(input, output, session) {
306	2x	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
307
308	2x	selector_list <- teal.transform::data_extract_multiple_srv(
309	2x	data_extract = list(variables = variables),
310	2x	datasets = data,
311	2x	select_validation_rule = list(
312	2x	variables = ~ if (length(.) <= 1) "Please select at least 2 columns."
313		)
314		)
315
316	2x	iv_r <- reactive({
317	2x	iv <- shinyvalidate::InputValidator$new()
318	2x	teal.transform::compose_and_enable_validators(iv, selector_list)
319		})
320
321	2x	anl_merged_input <- teal.transform::merge_expression_srv(
322	2x	datasets = data,
323	2x	selector_list = selector_list
324		)
325
326	2x	anl_merged_q <- reactive({
327	2x	req(anl_merged_input())
328	2x	obj <- data()
329	2x	teal.reporter::teal_card(obj) <- c(
330	2x	teal.reporter::teal_card(obj),
331	2x	teal.reporter::teal_card("## Module's output(s)")
332		)
333	2x	qenv <- teal.code::eval_code(obj, "library(dplyr);library(lattice)")
334	2x	teal.code::eval_code(qenv, as.expression(anl_merged_input()$expr))
335		})
336
337	2x	merged <- list(
338	2x	anl_input_r = anl_merged_input,
339	2x	anl_q_r = anl_merged_q
340		)
341
342		# plot
343	2x	output_q <- reactive({
344	2x	teal::validate_inputs(iv_r())
345
346	2x	qenv <- merged$anl_q_r()
347	2x	ANL <- qenv[["ANL"]]
348
349	2x	cols_names <- merged$anl_input_r()$columns_source$variables
350	2x	alpha <- input$alpha
351	2x	cex <- input$cex
352	2x	add_cor <- input$cor
353	2x	cor_method <- input$cor_method
354	2x	cor_na_omit <- input$cor_na_omit
355
356	2x	cor_na_action <- if (isTruthy(cor_na_omit)) {
357	!	"na.omit"
358		} else {
359	2x	"na.fail"
360		}
361
362	2x	teal::validate_has_data(ANL, 10)
363	2x	teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE)
364
365		# get labels and proper variable names
366	2x	varnames <- varname_w_label(cols_names, ANL, wrap_width = 20)
367
368		# check character columns. If any, then those are converted to factors
369	2x	check_char <- vapply(ANL[, cols_names], is.character, logical(1))
370	2x	if (any(check_char)) {
371	!	qenv <- teal.code::eval_code(
372	!	qenv,
373	!	substitute(
374	!	expr = ANL <- ANL[, cols_names] %>%
375	!	dplyr::mutate_if(is.character, as.factor) %>%
376	!	droplevels(),
377	!	env = list(cols_names = cols_names)
378		)
379		)
380		} else {
381	2x	qenv <- teal.code::eval_code(
382	2x	qenv,
383	2x	substitute(
384	2x	expr = ANL <- ANL[, cols_names] %>%
385	2x	droplevels(),
386	2x	env = list(cols_names = cols_names)
387		)
388		)
389		}
390
391
392		# create plot
393	2x	teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "### Plot")
394
395	2x	if (add_cor) {
396	!	shinyjs::show("cor_method")
397	!	shinyjs::show("cor_use")
398	!	shinyjs::show("cor_na_omit")
399
400	!	qenv <- teal.code::eval_code(
401	!	qenv,
402	!	substitute(
403	!	expr = {
404	!	plot <- lattice::splom(
405	!	ANL,
406	!	varnames = varnames_value,
407	!	panel = function(x, y, ...) {
408	!	lattice::panel.splom(x = x, y = y, ...)
409	!	cpl <- lattice::current.panel.limits()
410	!	lattice::panel.text(
411	!	mean(cpl$xlim),
412	!	mean(cpl$ylim),
413	!	get_scatterplotmatrix_stats(
414	!	x,
415	!	y,
416	!	.f = stats::cor.test,
417	!	.f_args = list(method = cor_method, na.action = cor_na_action)
418		),
419	!	alpha = 0.6,
420	!	fontsize = 18,
421	!	fontface = "bold"
422		)
423		},
424	!	pch = 16,
425	!	alpha = alpha_value,
426	!	cex = cex_value
427		)
428		},
429	!	env = list(
430	!	varnames_value = varnames,
431	!	cor_method = cor_method,
432	!	cor_na_action = cor_na_action,
433	!	alpha_value = alpha,
434	!	cex_value = cex
435		)
436		)
437		)
438		} else {
439	2x	shinyjs::hide("cor_method")
440	2x	shinyjs::hide("cor_use")
441	2x	shinyjs::hide("cor_na_omit")
442	2x	qenv <- teal.code::eval_code(
443	2x	qenv,
444	2x	substitute(
445	2x	expr = {
446	2x	plot <- lattice::splom(
447	2x	ANL,
448	2x	varnames = varnames_value,
449	2x	pch = 16,
450	2x	alpha = alpha_value,
451	2x	cex = cex_value
452		)
453		},
454	2x	env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)
455		)
456		)
457		}
458	2x	qenv
459		})
460
461	2x	decorated_output_q <- srv_decorate_teal_data(
462	2x	id = "decorator",
463	2x	data = output_q,
464	2x	decorators = select_decorators(decorators, "plot"),
465	2x	expr = quote(plot)
466		)
467
468	2x	plot_r <- reactive(req(decorated_output_q())[["plot"]])
469
470		# Insert the plot into a plot_with_settings module
471	2x	pws <- teal.widgets::plot_with_settings_srv(
472	2x	id = "myplot",
473	2x	plot_r = plot_r,
474	2x	height = plot_height,
475	2x	width = plot_width
476		)
477
478		# show a message if conversion to factors took place
479	2x	output$message <- renderText({
480	2x	req(iv_r()$is_valid())
481	2x	req(selector_list()$variables())
482	2x	ANL <- merged$anl_q_r()[["ANL"]]
483	2x	cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))
484	2x	check_char <- vapply(ANL[, cols_names], is.character, logical(1))
485	2x	if (any(check_char)) {
486	!	is_single <- sum(check_char) == 1
487	!	paste(
488	!	"Character",
489	!	ifelse(is_single, "variable", "variables"),
490	!	paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
491	!	ifelse(is_single, "was", "were"),
492	!	"converted to",
493	!	ifelse(is_single, "factor.", "factors.")
494		)
495		} else {
496		""
497		}
498		})
499
500	2x	set_chunk_dims(pws, decorated_output_q)
501		})
502		}
503
504		#' Get stats for x-y pairs in scatterplot matrix
505		#'
506		#' Uses [stats::cor.test()] per default for all numerical input variables and converts results
507		#' to character vector.
508		#' Could be extended if different stats for different variable types are needed.
509		#' Meant to be called from [lattice::panel.text()].
510		#'
511		#' Presently we need to use a formula input for `stats::cor.test` because
512		#' `na.fail` only gets evaluated when a formula is passed (see below).
513		#' ```
514		#' x = c(1,3,5,7,NA)
515		#' y = c(3,6,7,8,1)
516		#' stats::cor.test(x, y, na.action = "na.fail")
517		#' stats::cor.test(~ x + y, na.action = "na.fail")
518		#' ```
519		#'
520		#' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length.
521		#' @param .f (`function`) function that accepts x and y as formula input `~ x + y`.
522		#' Default `stats::cor.test`.
523		#' @param .f_args (`list`) of arguments to be passed to `.f`.
524		#' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate.
525		#' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value.
526		#'
527		#' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value.
528		#'
529		#' @examples
530		#' set.seed(1)
531		#' x <- runif(25, 0, 1)
532		#' y <- runif(25, 0, 1)
533		#' x[c(3, 10, 18)] <- NA
534		#'
535		#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))
536		#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(
537		#' method = "pearson",
538		#' na.action = na.fail
539		#' ))
540		#'
541		#' @export
542		#'
543		get_scatterplotmatrix_stats <- function(x, y,
544		.f = stats::cor.test,
545		.f_args = list(),
546		round_stat = 2,
547		round_pval = 4) {
548	6x	if (is.numeric(x) && is.numeric(y)) {
549	3x	stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)
550
551	3x	if (anyNA(stat)) {
552	1x	return("NA")
553	2x	} else if (all(c("estimate", "p.value") %in% names(stat))) {
554	2x	return(paste(
555	2x	c(
556	2x	paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),
557	2x	paste0("P:", round(stat$p.value, round_pval))
558		),
559	2x	collapse = "\n"
560		))
561		} else {
562	!	stop("function not supported")
563		}
564		} else {
565	3x	if ("method" %in% names(.f_args)) {
566	3x	if (.f_args$method == "pearson") {
567	1x	return("cor:-")
568		}
569	2x	if (.f_args$method == "kendall") {
570	1x	return("tau:-")
571		}
572	1x	if (.f_args$method == "spearman") {
573	1x	return("rho:-")
574		}
575		}
576	!	return("-")
577		}
578		}

1		#' Shared parameters documentation
2		#'
3		#' Defines common arguments shared across multiple functions in the package
4		#' to avoid repetition by using `inheritParams`.
5		#'
6		#' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of
7		#' `value`, `min`, and `max` intended for use with a slider UI element.
8		#' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of
9		#' `value`, `min`, and `max` for a slider encoding the plot width.
10		#' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not
11		#' rotate by default (`FALSE`).
12		#' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`.
13		#' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]
14		#' with settings for the module plot.
15		#' The argument is merged with options variable `teal.ggplot2_args` and default module setup.
16		#'
17		#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
18		#' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]
19		#' with settings for the module table.
20		#' The argument is merged with options variable `teal.basic_table_args` and default module setup.
21		#'
22		#' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
23		#' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output,
24		#' providing context or a title.
25		#' with text placed before the output to put the output into context. For example a title.
26		#' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output,
27		#' adding context or further instructions. Elements like `shiny::helpText()` are useful.
28		#' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity.
29		#' - When the length of `alpha` is one: the plot points will have a fixed opacity.
30		#' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on
31		#' vector of `value`, `min`, and `max`.
32		#' @param size (`integer(1)` or `integer(3)`) optional, specifies point size.
33		#' - When the length of `size` is one: the plot point sizes will have a fixed size.
34		#' - When the length of `size` is three: the plot points size are dynamically adjusted based on
35		#' vector of `value`, `min`, and `max`.
36		#' @param decorators `r lifecycle::badge("experimental")`
37		#' (named `list` of lists of `teal_transform_module`) optional,
38		#' decorator for tables or plots included in the module output reported.
39		#' The decorators are applied to the respective output objects.
40		#'
41		#' See section "Decorating Module" below for more details.
42		#'
43		#' @return Object of class `teal_module` to be used in `teal` applications.
44		#'
45		#' @name shared_params
46		#' @keywords internal
47		NULL
48
49		#' Add labels for facets to a `ggplot2` object
50		#'
51		#' Enhances a `ggplot2` plot by adding labels that describe
52		#' the faceting variables along the x and y axes.
53		#'
54		#' @param p (`ggplot2`) object to which facet labels will be added.
55		#' @param xfacet_label (`character`) Label for the facet along the x-axis.
56		#' If `NULL`, no label is added. If a vector, labels are joined with " & ".
57		#' @param yfacet_label (`character`) Label for the facet along the y-axis.
58		#' Similar behavior to `xfacet_label`.
59		#'
60		#' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`)
61		#'
62		#' @examples
63		#' library(ggplot2)
64		#' library(grid)
65		#'
66		#' p <- ggplot(mtcars) +
67		#' aes(x = mpg, y = disp) +
68		#' geom_point() +
69		#' facet_grid(gear ~ cyl)
70		#'
71		#' xfacet_label <- "cylinders"
72		#' yfacet_label <- "gear"
73		#' res <- add_facet_labels(p, xfacet_label, yfacet_label)
74		#' grid.newpage()
75		#' grid.draw(res)
76		#'
77		#' grid.newpage()
78		#' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))
79		#' grid.newpage()
80		#' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))
81		#' grid.newpage()
82		#' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))
83		#'
84		#' @export
85		#'
86		add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
87	!	checkmate::assert_class(p, classes = "ggplot")
88	!	checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)
89	!	checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)
90	!	if (is.null(xfacet_label) && is.null(yfacet_label)) {
91	!	return(ggplot2::ggplotGrob(p))
92		}
93	!	grid::grid.grabExpr({
94	!	g <- ggplot2::ggplotGrob(p)
95
96		# we are going to replace these, so we make sure they have nothing in them
97	!	checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
98	!	checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
99
100	!	xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
101	!	xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")
102	!	yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
103	!	yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")
104	!	yaxis_label_grob$children[[1]]$rot <- 270
105
106	!	top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")
107	!	right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")
108
109	!	grid::grid.newpage()
110	!	grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))
111	!	grid::grid.draw(g)
112	!	grid::upViewport(1)
113
114		# draw x facet
115	!	if (!is.null(xfacet_label)) {
116	!	grid::pushViewport(grid::viewport(
117	!	x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),
118	!	height = top_height, just = c("left", "bottom"), name = "topxaxis"
119		))
120	!	grid::grid.draw(xaxis_label_grob)
121	!	grid::upViewport(1)
122		}
123
124		# draw y facet
125	!	if (!is.null(yfacet_label)) {
126	!	grid::pushViewport(grid::viewport(
127	!	x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,
128	!	height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
129		))
130	!	grid::grid.draw(yaxis_label_grob)
131	!	grid::upViewport(1)
132		}
133		})
134		}
135
136		#' Call a function with a character vector for the `...` argument
137		#'
138		#' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`.
139		#' @param str_args (`character`) A character vector that the function shall be executed with
140		#'
141		#' @return
142		#' Value of call to `fun` with arguments specified in `str_args`.
143		#'
144		#' @keywords internal
145		call_fun_dots <- function(fun, str_args) {
146	!	do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
147		}
148
149		#' Generate a string for a variable including its label
150		#'
151		#' @param var_names (`character`) Name of variable to extract labels from.
152		#' @param dataset (`dataset`) Name of analysis dataset.
153		#' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label.
154		#' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80.
155		#'
156		#' @return (`character`) String with variable name and label.
157		#'
158		#' @keywords internal
159		#'
160		varname_w_label <- function(var_names,
161		dataset,
162		wrap_width = 80,
163		prefix = NULL,
164		suffix = NULL) {
165	61x	add_label <- function(var_names) {
166	64x	label <- vapply(
167	64x	dataset[var_names], function(x) {
168	64x	attr_label <- attr(x, "label")
169	!	`if`(is.null(attr_label), "", attr_label)
170		},
171	64x	character(1)
172		)
173
174	64x	if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
175	64x	paste0(prefix, label, " [", var_names, "]", suffix)
176		} else {
177	!	var_names
178		}
179		}
180
181	61x	if (length(var_names) < 1) {
182	!	NULL
183	61x	} else if (length(var_names) == 1) {
184	59x	stringr::str_wrap(add_label(var_names), width = wrap_width)
185	2x	} else if (length(var_names) > 1) {
186	2x	stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)
187		}
188		}
189
190		# see vignette("ggplot2-specs", package="ggplot2")
191		shape_names <- c(
192		"circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
193		"square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
194		"diamond", paste("diamond", c("open", "filled", "plus")),
195		"triangle", paste("triangle", c("open", "filled", "square")),
196		paste("triangle down", c("open", "filled")),
197		"plus", "cross", "asterisk"
198		)
199
200		#' Get icons to represent variable types in dataset
201		#'
202		#' @param var_type (`character`) of R internal types (classes).
203		#' @return (`character`) vector of HTML icons corresponding to data type in each column.
204		#' @keywords internal
205		variable_type_icons <- function(var_type) {
206	31x	checkmate::assert_character(var_type, any.missing = FALSE)
207
208	31x	class_to_icon <- list(
209	31x	numeric = "arrow-up-1-9",
210	31x	integer = "arrow-up-1-9",
211	31x	logical = "pause",
212	31x	Date = "calendar",
213	31x	POSIXct = "calendar",
214	31x	POSIXlt = "calendar",
215	31x	factor = "chart-bar",
216	31x	character = "keyboard",
217	31x	primary_key = "key",
218	31x	unknown = "circle-question"
219		)
220	31x	class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))
221
222	31x	unname(vapply(
223	31x	var_type,
224	31x	FUN.VALUE = character(1),
225	31x	FUN = function(class) {
226	66x	if (class == "") {
227	!	class
228	66x	} else if (is.null(class_to_icon[[class]])) {
229	1x	class_to_icon[["unknown"]]
230		} else {
231	65x	class_to_icon[[class]]
232		}
233		}
234		))
235		}
236
237		#' JavaScript expression to check if a tab is active
238		#'
239		#' @param id (`character(1)`) the id of the tab panel with tabs.
240		#' @param name (`character(1)`) the name of the tab.
241		#' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine
242		#' if the specified tab is active.
243		#' @keywords internal
244		#'
245		is_tab_active_js <- function(id, name) {
246		# supporting the bs3 and higher version at the same time
247	30x	sprintf(
248	30x	"$(\"#%1$s > li.active\").text().trim() == '%2$s' \|\| $(\"#%1$s > li a.active\").text().trim() == '%2$s'",
249	30x	id, name
250		)
251		}
252
253		#' Assert single selection on `data_extract_spec` object
254		#' Helper to reduce code in assertions
255		#' @noRd
256		#'
257		assert_single_selection <- function(x,
258		.var.name = checkmate::vname(x)) { # nolint: object_name.
259	172x	if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
260	7x	stop("'", .var.name, "' should not allow multiple selection")
261		}
262	165x	invisible(TRUE)
263		}
264
265		#' Wrappers around `srv_transform_teal_data` that allows to decorate the data
266		#' @inheritParams teal::srv_transform_teal_data
267		#' @inheritParams teal.reporter::`eval_code,teal_report-method`
268		#' @param expr (`reactive`) with expression to evaluate on the output of the
269		#' decoration. It must be compatible with `code` argument of [teal.code::eval_code()].
270		#' Default is `NULL` which won't evaluate any appending code.
271		#' @details
272		#' `srv_decorate_teal_data` is a wrapper around `srv_transform_teal_data` that
273		#' allows to decorate the data with additional expressions.
274		#' When original `teal_data` object is in error state, it will show that error
275		#' first.
276		#'
277		#' @keywords internal
278		srv_decorate_teal_data <- function(id, data, decorators, expr) {
279	67x	checkmate::assert_class(data, classes = "reactive")
280	67x	checkmate::assert_list(decorators, "teal_transform_module")
281
282	67x	no_expr <- missing(expr)
283
284	67x	moduleServer(id, function(input, output, session) {
285	67x	decorated_output <- srv_transform_teal_data("inner", data = data, transformators = decorators)
286
287	67x	expr_r <- if (is.reactive(expr)) expr else reactive(expr)
288
289	67x	reactive({
290	77x	req(decorated_output())
291	58x	if (no_expr) {
292	!	decorated_output()
293		} else {
294	58x	teal.code::eval_code(decorated_output(), expr_r())
295		}
296		})
297		})
298		}
299
300		#' @rdname srv_decorate_teal_data
301		#' @details
302		#' `ui_decorate_teal_data` is a wrapper around `ui_transform_teal_data`.
303		#' @keywords internal
304		ui_decorate_teal_data <- function(id, decorators, ...) {
305	24x	teal::ui_transform_teal_data(NS(id, "inner"), transformators = decorators, ...)
306		}
307
308		#' Internal function to check if decorators is a valid object
309		#' @noRd
310		check_decorators <- function(x, names = NULL) { # nolint: object_name.
311
312	128x	check_message <- checkmate::check_list(x, names = "named")
313
314	128x	if (!is.null(names)) {
315	128x	if (isTRUE(check_message)) {
316	128x	if (length(names(x)) != length(unique(names(x)))) {
317	!	check_message <- sprintf(
318	!	"The `decorators` must contain unique names from these names: %s.",
319	!	paste(names, collapse = ", ")
320		)
321		}
322		} else {
323	!	check_message <- sprintf(
324	!	"The `decorators` must be a named list from these names: %s.",
325	!	paste(names, collapse = ", ")
326		)
327		}
328		}
329
330	128x	if (!isTRUE(check_message)) {
331	!	return(check_message)
332		}
333
334	128x	valid_elements <- vapply(
335	128x	x,
336	128x	checkmate::test_class,
337	128x	classes = "teal_transform_module",
338	128x	FUN.VALUE = logical(1L)
339		)
340
341	128x	if (all(valid_elements)) {
342	122x	return(TRUE)
343		}
344
345	6x	"Make sure that the named list contains 'teal_transform_module' objects created using `teal_transform_module()`."
346		}
347		#' Internal assertion on decorators
348		#' @noRd
349		assert_decorators <- checkmate::makeAssertionFunction(check_decorators)
350
351		#' Subset decorators based on the scope
352		#'
353		#' @param scope (`character`) a character vector of decorator names to include.
354		#' @param decorators (named `list`) of list decorators to subset.
355		#'
356		#' @return Subsetted list with all decorators to include.
357		#' It can be an empty list if none of the scope exists in `decorators` argument.
358		#' @keywords internal
359		select_decorators <- function(decorators, scope) {
360	91x	checkmate::assert_character(scope, null.ok = TRUE)
361	91x	if (scope %in% names(decorators)) {
362	!	decorators[scope]
363		} else {
364	91x	list()
365		}
366		}
367
368		#' Set the attributes of the last chunk outputs
369		#' @param teal_card (`teal_card`) object to modify.
370		#' @param attributes (`list`) of attributes to set on the last chunk outputs.
371		#' @param n (`integer(1)`) number of the last element of `teal_card` to modify.
372		#' it will only change `chunk_output` objects.
373		#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
374		#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
375		#' @keywords internal
376		set_chunk_attrs <- function(teal_card,
377		attributes,
378		n = 1,
379		inner_classes = NULL,
380		quiet = FALSE) {
381	12x	checkmate::assert_class(teal_card, "teal_card")
382	12x	checkmate::assert_list(attributes, names = "unique")
383	12x	checkmate::assert_int(n, lower = 1)
384	12x	checkmate::assert_character(inner_classes, null.ok = TRUE)
385	12x	checkmate::assert_flag(quiet)
386
387	12x	if (!inherits(teal_card[[length(teal_card)]], "chunk_output")) {
388	1x	if (!quiet) {
389	1x	warning("The last element of the `teal_card` is not a `chunk_output` object. No attributes were modified.")
390		}
391	1x	return(teal_card)
392		}
393
394	11x	for (ix in seq_len(length(teal_card))) {
395	24x	if (ix > n) {
396	9x	break
397		}
398	15x	current_ix <- length(teal_card) + 1 - ix
399	15x	if (!inherits(teal_card[[current_ix]], "chunk_output")) {
400	2x	if (!quiet) {
401	1x	warning(
402	1x	"The ", ix,
403	1x	" to last element of the `teal_card` is not a `chunk_output` object. Skipping any further modifications."
404		)
405		}
406	2x	return(teal_card)
407		}
408
409		if (
410	13x	length(inner_classes) > 0 &&
411	13x	length(teal_card[[current_ix]]) >= 1 &&
412	13x	!checkmate::test_multi_class(teal_card[[current_ix]][[1]], inner_classes)
413		) {
414	1x	next
415		}
416
417	12x	attributes(teal_card[[current_ix]]) <- utils::modifyList(
418	12x	attributes(teal_card[[current_ix]]),
419	12x	attributes
420		)
421		}
422
423	9x	teal_card
424		}
425
426		#' Create a reactive that sets plot dimensions on a `teal_card`
427		#'
428		#' This is a convenience function that creates a reactive expression that
429		#' automatically sets the `dev.width` and `dev.height` attributes on the last
430		#' chunk outputs of a `teal_card` based on plot dimensions from a plot widget.
431		#'
432		#' @param pws (`plot_widget`) plot widget that provides dimensions via `dim()` method
433		#' @param q_r (`reactive`) reactive expression that returns a `teal_reporter`
434		#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
435		#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
436		#'
437		#' @return A reactive expression that returns the `teal_card` with updated dimensions
438		#'
439		#' @keywords internal
440		set_chunk_dims <- function(pws, q_r, inner_classes = NULL) {
441	83x	checkmate::assert_list(pws)
442	83x	checkmate::assert_names(names(pws), must.include = "dim")
443	83x	checkmate::assert_class(pws$dim, "reactive")
444	83x	checkmate::assert_class(q_r, "reactive")
445	83x	checkmate::assert_character(inner_classes, null.ok = TRUE)
446
447	83x	reactive({
448	6x	pws_dim <- stats::setNames(as.list(req(pws$dim())), c("width", "height"))
449	6x	if (identical(pws_dim$width, "auto")) { # ignore non-numeric values (such as "auto")
450	1x	pws_dim$width <- NULL
451		}
452	6x	if (identical(pws_dim$height, "auto")) { # ignore non-numeric values (such as "auto")
453	!	pws_dim$height <- NULL
454		}
455	6x	q <- req(q_r())
456	6x	teal.reporter::teal_card(q) <- set_chunk_attrs(
457	6x	teal.reporter::teal_card(q),
458	6x	list(dev.width = pws_dim$width, dev.height = pws_dim$height),
459	6x	inner_classes = inner_classes
460		)
461	6x	q
462		})
463		}

1		#' `teal` module: File viewer
2		#'
3		#' The file viewer module provides a tool to view static files.
4		#' Supported formats include text formats, `PDF`, `PNG` `APNG`,
5		#' `JPEG` `SVG`, `WEBP`, `GIF` and `BMP`.
6		#'
7		#' @inheritParams teal::module
8		#' @inheritParams shared_params
9		#' @param input_path (`list`) of the input paths, optional. Each element can be:
10		#'
11		#' Paths can be specified as absolute paths or relative to the running directory of the application.
12		#' Default to the current working directory if not supplied.
13		#'
14		#' @inherit shared_params return
15		#'
16		#' @examplesShinylive
17		#' library(teal.modules.general)
18		#' interactive <- function() TRUE
19		#' {{ next_example }}
20		#' @examples
21		#' data <- teal_data()
22		#' data <- within(data, {
23		#' data <- data.frame(1)
24		#' })
25		#'
26		#' app <- init(
27		#' data = data,
28		#' modules = modules(
29		#' tm_file_viewer(
30		#' input_path = list(
31		#' folder = system.file("sample_files", package = "teal.modules.general"),
32		#' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
33		#' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
34		#' url = file.path(
35		#' "https://www.fda.gov/files/drugs/published",
36		#' "Portable-Document-Format-Specifications.pdf"
37		#' )
38		#' )
39		#' )
40		#' )
41		#' )
42		#' if (interactive()) {
43		#' shinyApp(app$ui, app$server)
44		#' }
45		#'
46		#' @export
47		#'
48		tm_file_viewer <- function(label = "File Viewer Module",
49		input_path = list("Current Working Directory" = ".")) {
50	!	message("Initializing tm_file_viewer")
51
52		# Normalize the parameters
53	!	if (length(label) == 0 \|\| identical(label, "")) label <- " "
54	!	if (length(input_path) == 0 \|\| identical(input_path, "")) input_path <- list()
55
56		# Start of assertions
57	!	checkmate::assert_string(label)
58
59	!	checkmate::assert(
60	!	checkmate::check_list(input_path, types = "character", min.len = 0),
61	!	checkmate::check_character(input_path, min.len = 1)
62		)
63	!	if (length(input_path) > 0) {
64	!	valid_url <- function(url_input, timeout = 2) {
65	!	con <- try(url(url_input), silent = TRUE)
66	!	check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1])
67	!	try(close.connection(con), silent = TRUE)
68	!	is.null(check)
69		}
70	!	idx <- vapply(input_path, function(x) file.exists(x) \|\| valid_url(x), logical(1))
71
72	!	if (!all(idx)) {
73	!	warning(
74	!	paste0(
75	!	"Non-existent file or url path. Please provide valid paths for:\n",
76	!	paste0(input_path[!idx], collapse = "\n")
77		)
78		)
79		}
80	!	input_path <- input_path[idx]
81		} else {
82	!	warning(
83	!	"No file or url paths were provided."
84		)
85		}
86		# End of assertions
87
88		# Make UI args
89	!	args <- as.list(environment())
90
91	!	ans <- module(
92	!	label = label,
93	!	server = srv_viewer,
94	!	server_args = list(input_path = input_path),
95	!	ui = ui_viewer,
96	!	ui_args = args,
97	!	datanames = NULL
98		)
99	!	attr(ans, "teal_bookmarkable") <- FALSE
100	!	ans
101		}
102
103		# UI function for the file viewer module
104		ui_viewer <- function(id, ...) {
105	!	args <- list(...)
106	!	ns <- NS(id)
107
108	!	tagList(
109	!	teal.widgets::standard_layout(
110	!	output = tags$div(
111	!	uiOutput(ns("output"))
112		),
113	!	encoding = tags$div(
114	!	style = "overflow-y: hidden; overflow-x: auto;",
115	!	tags$label("Encodings", class = "text-primary"),
116	!	shinyTree::shinyTree(
117	!	ns("tree"),
118	!	dragAndDrop = FALSE,
119	!	sort = FALSE,
120	!	theme = "proton",
121	!	multiple = FALSE,
122	!	search = TRUE
123		)
124		)
125		)
126		)
127		}
128
129		# Server function for the file viewer module
130		srv_viewer <- function(id, input_path) {
131	!	moduleServer(id, function(input, output, session) {
132	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
133
134	!	temp_dir <- tempfile()
135	!	if (!dir.exists(temp_dir)) {
136	!	dir.create(temp_dir, recursive = TRUE)
137		}
138	!	addResourcePath(basename(temp_dir), temp_dir)
139
140	!	test_path_text <- function(selected_path, type) {
141	!	out <- tryCatch(
142	!	expr = {
143	!	if (type != "url") {
144	!	selected_path <- normalizePath(selected_path, winslash = "/")
145		}
146	!	readLines(con = selected_path)
147		},
148	!	error = function(cond) FALSE,
149	!	warning = function(cond) {
150	!	`if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
151		}
152		)
153		}
154
155	!	handle_connection_type <- function(selected_path) {
156	!	file_extension <- tools::file_ext(selected_path)
157	!	file_class <- suppressWarnings(file(selected_path))
158	!	close(file_class)
159
160	!	output_text <- test_path_text(selected_path, type = class(file_class)[1])
161
162	!	if (class(file_class)[1] == "url") {
163	!	list(selected_path = selected_path, output_text = output_text)
164		} else {
165	!	file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)
166	!	selected_path <- file.path(basename(temp_dir), basename(selected_path))
167	!	list(selected_path = selected_path, output_text = output_text)
168		}
169		}
170
171	!	display_file <- function(selected_path) {
172	!	con_type <- handle_connection_type(selected_path)
173	!	file_extension <- tools::file_ext(selected_path)
174	!	if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
175	!	tags$img(src = con_type$selected_path, alt = "file does not exist")
176	!	} else if (file_extension == "pdf") {
177	!	tags$embed(
178	!	style = "height: 600px; width: 100%;",
179	!	src = con_type$selected_path
180		)
181	!	} else if (!isFALSE(con_type$output_text[1])) {
182	!	tags$pre(paste0(con_type$output_text, collapse = "\n"))
183		} else {
184	!	tags$p("Please select a supported format.")
185		}
186		}
187
188	!	tree_list <- function(file_or_dir) {
189	!	nested_list <- lapply(file_or_dir, function(path) {
190	!	file_class <- suppressWarnings(file(path))
191	!	close(file_class)
192	!	if (class(file_class)[[1]] != "url") {
193	!	isdir <- file.info(path)$isdir
194	!	if (!isdir) {
195	!	structure(path, ancestry = path, sticon = "file")
196		} else {
197	!	files <- list.files(path, full.names = TRUE, include.dirs = TRUE)
198	!	out <- lapply(files, function(x) tree_list(x))
199	!	out <- unlist(out, recursive = FALSE)
200	!	if (length(files) > 0) names(out) <- basename(files)
201	!	out
202		}
203		} else {
204	!	structure(path, ancestry = path, sticon = "file")
205		}
206		})
207
208	!	missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")
209	!	names(nested_list)[missing_labels] <- file_or_dir[missing_labels]
210	!	nested_list
211		}
212
213	!	output$tree <- shinyTree::renderTree({
214	!	if (length(input_path) > 0) {
215	!	tree_list(input_path)
216		} else {
217	!	list("Empty Path" = NULL)
218		}
219		})
220
221	!	output$output <- renderUI({
222	!	validate(
223	!	need(
224	!	length(shinyTree::get_selected(input$tree)) > 0,
225	!	"Please select a file."
226		)
227		)
228
229	!	obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]
230	!	repo <- attr(obj, "ancestry")
231	!	repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo
232	!	is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]
233
234	!	if (is_not_named) {
235	!	selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
236		} else {
237	!	if (length(repo) == 0) {
238	!	selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
239		} else {
240	!	selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
241		}
242		}
243
244	!	validate(
245	!	need(
246	!	!isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,
247	!	"Please select a single file."
248		)
249		)
250	!	display_file(selected_path)
251		})
252
253	!	onStop(function() {
254	!	removeResourcePath(basename(temp_dir))
255	!	unlink(temp_dir)
256		})
257		})
258		}

1		#' `teal` module: Data table viewer
2		#'
3		#' Module provides a dynamic and interactive way to view `data.frame`s in a `teal` application.
4		#' It uses the `DT` package to display data tables in a paginated, searchable, and sortable format,
5		#' which helps to enhance data exploration and analysis.
6		#'
7		#' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables.
8		#' Configure the `DT.TOJSON_ARGS` option via
9		#' `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module.
10		#' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical.
11		#'
12		#' @inheritParams teal::module
13		#' @inheritParams shared_params
14		#' @param variables_selected (`named list`) Character vectors of the variables (i.e. columns)
15		#' which should be initially shown for each dataset.
16		#' Names of list elements should correspond to the names of the datasets available in the app.
17		#' If no entry is specified for a dataset, the first six variables from that
18		#' dataset will initially be shown.
19		#' @param datasets_selected (`character`) `r lifecycle::badge("deprecated")` A vector of datasets which should be
20		#' shown and in what order. Use `datanames` instead.
21		#' @param dt_args (`named list`) Additional arguments to be passed to [DT::datatable()]
22		#' (must not include `data` or `options`).
23		#' @param dt_options (`named list`) The `options` argument to `DT::datatable`. By default
24		#' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`
25		#' @param server_rendering (`logical`) should the data table be rendered server side
26		#' (see `server` argument of [DT::renderDataTable()])
27		#'
28		#' @inherit shared_params return
29		#'
30		#' @examplesShinylive
31		#' library(teal.modules.general)
32		#' interactive <- function() TRUE
33		#' {{ next_example }}
34		#' @examples
35		#' # general data example
36		#' data <- teal_data()
37		#' data <- within(data, {
38		#' require(nestcolor)
39		#' iris <- iris
40		#' })
41		#'
42		#' app <- init(
43		#' data = data,
44		#' modules = modules(
45		#' tm_data_table(
46		#' variables_selected = list(
47		#' iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
48		#' ),
49		#' dt_args = list(caption = "IRIS Table Caption")
50		#' )
51		#' )
52		#' )
53		#' if (interactive()) {
54		#' shinyApp(app$ui, app$server)
55		#' }
56		#'
57		#' @examplesShinylive
58		#' library(teal.modules.general)
59		#' interactive <- function() TRUE
60		#' {{ next_example }}
61		#' @examples
62		#' # CDISC data example
63		#' data <- teal_data()
64		#' data <- within(data, {
65		#' require(nestcolor)
66		#' ADSL <- teal.data::rADSL
67		#' })
68		#' join_keys(data) <- default_cdisc_join_keys[names(data)]
69		#'
70		#' app <- init(
71		#' data = data,
72		#' modules = modules(
73		#' tm_data_table(
74		#' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
75		#' dt_args = list(caption = "ADSL Table Caption")
76		#' )
77		#' )
78		#' )
79		#' if (interactive()) {
80		#' shinyApp(app$ui, app$server)
81		#' }
82		#'
83		#' @export
84		#'
85		tm_data_table <- function(label = "Data Table",
86		variables_selected = list(),
87		datasets_selected = deprecated(),
88		datanames = if (missing(datasets_selected)) "all" else datasets_selected,
89		dt_args = list(),
90		dt_options = list(
91		searching = FALSE,
92		pageLength = 30,
93		lengthMenu = c(5, 15, 30, 100),
94		scrollX = TRUE
95		),
96		server_rendering = FALSE,
97		pre_output = NULL,
98		post_output = NULL,
99		transformators = list()) {
100	!	message("Initializing tm_data_table")
101
102		# Start of assertions
103	!	checkmate::assert_string(label)
104
105	!	checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")
106	!	if (length(variables_selected) > 0) {
107	!	lapply(seq_along(variables_selected), function(i) {
108	!	checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)
109	!	if (!is.null(names(variables_selected[[i]]))) {
110	!	checkmate::assert_names(names(variables_selected[[i]]))
111		}
112		})
113		}
114	!	if (!missing(datasets_selected)) {
115	!	lifecycle::deprecate_stop(
116	!	when = "0.4.0",
117	!	what = "tm_data_table(datasets_selected)",
118	!	with = "tm_data_table(datanames)",
119	!	details = 'Use tm_data_table(datanames = "all") to keep the previous behavior and avoid this warning.',
120		)
121		}
122	!	checkmate::assert_character(datanames, min.len = 0, min.chars = 1, null.ok = TRUE)
123	!	checkmate::assert(
124	!	checkmate::check_list(dt_args, len = 0),
125	!	checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))
126		)
127	!	checkmate::assert_list(dt_options, names = "named")
128	!	checkmate::assert_flag(server_rendering)
129	!	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
130	!	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
131
132		# End of assertions
133
134	!	ans <- module(
135	!	label,
136	!	server = srv_page_data_table,
137	!	ui = ui_page_data_table,
138	!	datanames = datanames,
139	!	server_args = list(
140	!	datanames = if (is.null(datanames)) "all" else datanames,
141	!	variables_selected = variables_selected,
142	!	dt_args = dt_args,
143	!	dt_options = dt_options,
144	!	server_rendering = server_rendering
145		),
146	!	ui_args = list(
147	!	pre_output = pre_output,
148	!	post_output = post_output
149		),
150	!	transformators = transformators
151		)
152	!	attr(ans, "teal_bookmarkable") <- TRUE
153	!	ans
154		}
155
156		# UI page module
157		ui_page_data_table <- function(id, pre_output = NULL, post_output = NULL) {
158	!	ns <- NS(id)
159
160	!	tagList(
161	!	teal.widgets::standard_layout(
162	!	output = teal.widgets::white_small_well(
163	!	bslib::page_fluid(
164	!	checkboxInput(
165	!	ns("if_distinct"),
166	!	"Show only distinct rows:",
167	!	value = FALSE
168		)
169		),
170	!	bslib::page_fluid(
171	!	uiOutput(ns("dataset_table"))
172		)
173		),
174	!	pre_output = pre_output,
175	!	post_output = post_output
176		)
177		)
178		}
179
180		# Server page module
181		srv_page_data_table <- function(id,
182		data,
183		datanames,
184		variables_selected,
185		dt_args,
186		dt_options,
187		server_rendering) {
188	!	checkmate::assert_class(data, "reactive")
189	!	checkmate::assert_class(isolate(data()), "teal_data")
190	!	moduleServer(id, function(input, output, session) {
191	!	teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
192
193	!	if_filtered <- reactive(as.logical(input$if_filtered))
194	!	if_distinct <- reactive(as.logical(input$if_distinct))
195
196	!	datanames <- Filter(function(name) {
197	!	is.data.frame(isolate(data())[[name]])
198	!	}, if (identical(datanames, "all")) names(isolate(data())) else datanames)
199
200
201	!	output$dataset_table <- renderUI({
202	!	do.call(
203	!	tabsetPanel,
204	!	c(
205	!	list(id = session$ns("dataname_tab")),
206	!	lapply(
207	!	datanames,
208	!	function(x) {
209	!	dataset <- isolate(data()[[x]])
210	!	choices <- names(dataset)
211	!	labels <- vapply(
212	!	dataset,
213	!	function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),
214	!	character(1)
215		)
216	!	names(choices) <- ifelse(
217	!	is.na(labels) \| labels == "",
218	!	choices,
219	!	paste(choices, labels, sep = ": ")
220		)
221	!	variables_selected <- if (!is.null(variables_selected[[x]])) {
222	!	variables_selected[[x]]
223		} else {
224	!	utils::head(choices)
225		}
226	!	tabPanel(
227	!	title = x,
228	!	bslib::layout_columns(
229	!	col_widths = 12,
230	!	ui_data_table(
231	!	id = session$ns(x),
232	!	choices = choices,
233	!	selected = variables_selected
234		)
235		)
236		)
237		}
238		)
239		)
240		)
241		})
242
243	!	lapply(
244	!	datanames,
245	!	function(x) {
246	!	srv_data_table(
247	!	id = x,
248	!	data = data,
249	!	dataname = x,
250	!	if_filtered = if_filtered,
251	!	if_distinct = if_distinct,
252	!	dt_args = dt_args,
253	!	dt_options = dt_options,
254	!	server_rendering = server_rendering
255		)
256		}
257		)
258		})
259		}
260
261		# UI function for the data_table module
262		ui_data_table <- function(id, choices, selected) {
263	!	ns <- NS(id)
264
265	!	if (!is.null(selected)) {
266	!	all_choices <- choices
267	!	choices <- c(selected, setdiff(choices, selected))
268	!	names(choices) <- names(all_choices)[match(choices, all_choices)]
269		}
270
271	!	tagList(
272	!	teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
273	!	bslib::page_fluid(
274	!	teal.widgets::optionalSelectInput(
275	!	ns("variables"),
276	!	"Select variables:",
277	!	choices = choices,
278	!	selected = selected,
279	!	multiple = TRUE,
280	!	width = "100%"
281		)
282		),
283	!	bslib::page_fluid(
284	!	DT::dataTableOutput(ns("data_table"), width = "100%")
285		)
286		)
287		}
288
289		# Server function for the data_table module
290		srv_data_table <- function(id,
291		data,
292		dataname,
293		if_filtered,
294		if_distinct,
295		dt_args,
296		dt_options,
297		server_rendering) {
298	!	moduleServer(id, function(input, output, session) {
299	!	iv <- shinyvalidate::InputValidator$new()
300	!	iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
301	!	iv$add_rule("variables", shinyvalidate::sv_in_set(
302	!	set = names(isolate(data())[[dataname]]), message_fmt = "Not all selected variables exist in the data"
303		))
304	!	iv$enable()
305
306	!	data_table_data <- reactive({
307	!	df <- data()[[dataname]]
308
309	!	teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
310	!	qenv <- teal.code::eval_code(
311	!	data(),
312	!	"library(dplyr);library(DT)"
313		)
314	!	teal.code::eval_code(
315	!	qenv,
316	!	substitute(
317	!	expr = {
318	!	variables <- vars
319	!	dataframe_selected <- if (if_distinct) {
320	!	dplyr::count(dataname, dplyr::across(dplyr::all_of(variables)))
321		} else {
322	!	dataname[variables]
323		}
324	!	dt_args <- args
325	!	dt_args$options <- dt_options
326	!	if (!is.null(dt_rows)) {
327	!	dt_args$options$pageLength <- dt_rows
328		}
329	!	dt_args$data <- dataframe_selected
330	!	table <- do.call(DT::datatable, dt_args)
331		},
332	!	env = list(
333	!	dataname = as.name(dataname),
334	!	if_distinct = if_distinct(),
335	!	vars = input$variables,
336	!	args = dt_args,
337	!	dt_options = dt_options,
338	!	dt_rows = input$dt_rows
339		)
340		)
341		)
342		})
343
344	!	output$data_table <- DT::renderDataTable(server = server_rendering, {
345	!	teal::validate_inputs(iv)
346	!	req(data_table_data())[["table"]]
347		})
348		})
349		}

1		#' `teal` module: R Markdown render
2		#'
3		#' @description
4		#' `r lifecycle::badge("experimental")`
5		#'
6		#' Module to render R Markdown files using the data provided in the
7		#' `teal_data` object.
8		#'
9		#' The R Markdown file should be designed to accept variables available
10		#' in the data names of the module.
11		#'
12		#' @details
13		#' For example, if the `teal_data` object contains datasets named `mtcars`
14		#' and `iris`, the R Markdown file can use these as variables as they
15		#' will be available in the R Markdown environment.
16		#'
17		#' The libraries used in the R Markdown file must be available in the
18		#' deployed shiny app environment.
19		#'
20		#' When developing the R Markdown file, the working data can be simulated
21		#' on a code chunk, which in turn can look for the presence of `.raw_data`
22		#' object to determine if it is being run inside the `teal` module or not.
23		#'
24		#' Example R markdown file:
25		#'
26		#' ``````md
27		#' ---
28		#' title: "R Markdown Report"
29		#' output: html_document
30		#' ---
31		#'
32		#' ```{r eval=!exists(".raw_data")}
33		#' mtcars <- datasets::mtcars
34		#' iris <- datasets::iris
35		#' ```
36		#'
37		#' ```{r}
38		#' summary(mtcars) \|> print()
39		#' summary(iris) \|> print()
40		#' ```
41		#' ``````
42		#'
43		#' @inheritParams teal::module
44		#' @inheritParams shared_params
45		#'
46		#' @param rmd_content (`character`) Content of the R Markdown file to be rendered.
47		#' This can be the value of `readLines("path/to/file.Rmd")`.
48		#' @param allow_download (`logical`) whether to allow downloading of the R Markdown file.
49		#' Defaults to `TRUE`.
50		#' @param extra_transform (`list`) of [teal::teal_transform_module()] that will be added in the module's UI.
51		#' This can be used to create interactive inputs that modify the parameters in R Markdown rendering.
52		#'
53		#' @inherit shared_params return
54		#'
55		#' @inheritSection teal::example_module Reporting
56		#'
57		#' @examplesShinylive
58		#' library(teal.modules.general)
59		#' interactive <- function() TRUE
60		#' {{ next_example }}
61		#' @examples
62		#'
63		#' # general data example
64		#' data <- teal_data()
65		#' data <- within(data, {
66		#' CO2 <- CO2
67		#' })
68		#'
69		#' app <- init(
70		#' data = data,
71		#' modules = modules(
72		#' tm_rmarkdown(
73		#' label = "RMarkdown Module",
74		#' rmd_content = c(
75		#' "---",
76		#' "title: \"R Markdown Report\"",
77		#' "output: html_document",
78		#' "---",
79		#' "",
80		#' "```{r}",
81		#' "summary(CO2) \|> print()",
82		#' "```"
83		#' )
84		#' )
85		#' )
86		#' )
87		#' if (interactive()) {
88		#' shinyApp(app$ui, app$server)
89		#' }
90		#'
91		#' @examples
92		#' nrow_transform <- teal_transform_module(
93		#' label = "N Rows selector",
94		#' ui = function(id) {
95		#' ns <- NS(id)
96		#' tags$div(
97		#' numericInput(ns("n_rows"), "Show n rows", value = 40, min = 0, max = 200, step = 5)
98		#' )
99		#' },
100		#' server = function(id, data) {
101		#' moduleServer(id, function(input, output, session) {
102		#' reactive({
103		#' req(data())
104		#' within(data(),
105		#' {
106		#' n_rows <- n_rows_value
107		#' },
108		#' n_rows_value = input$n_rows
109		#' )
110		#' })
111		#' })
112		#' }
113		#' )
114		#'
115		#' app <- init(
116		#' data = data,
117		#' modules = modules(
118		#' tm_rmarkdown(
119		#' label = "RMarkdown Module",
120		#' rmd_content = readLines(
121		#' system.file(
122		#' file.path("sample_files", "co2_example.Rmd"),
123		#' package = "teal.modules.general"
124		#' )
125		#' ),
126		#' allow_download = FALSE,
127		#' extra_transform = list(nrow_transform)
128		#' )
129		#' )
130		#' )
131		#'
132		#' if (interactive()) {
133		#' shinyApp(app$ui, app$server)
134		#' }
135		#' @export
136		tm_rmarkdown <- function(label = "RMarkdown Module",
137		rmd_content,
138		datanames = "all",
139		allow_download = TRUE,
140		pre_output = NULL,
141		post_output = NULL,
142		transformators = list(),
143		extra_transform = list()) {
144	8x	message("Initializing tm_rmarkdown")
145
146		# Start of assertions
147
148	8x	checkmate::assert_string(label)
149	8x	checkmate::assert_character(rmd_content)
150	8x	checkmate::assert_flag(allow_download)
151
152	8x	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
153	8x	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
154
155		# End of assertions
156
157		# Make UI args
158	8x	args <- as.list(environment())
159
160	8x	ans <- module(
161	8x	label = label,
162	8x	server = srv_rmarkdown,
163	8x	server_args = list(rmd_content = rmd_content, allow_download = allow_download, extra_transform = extra_transform),
164	8x	ui = ui_rmarkdown,
165	8x	ui_args = args,
166	8x	transformators = transformators,
167	8x	datanames = datanames
168		)
169	8x	disable_src(ans)
170		}
171
172		# UI function for the rmarkdown module
173		ui_rmarkdown <- function(id, rmd_content, allow_download, extra_transform, ...) {
174	1x	args <- list(...)
175	1x	ns <- NS(id)
176
177	1x	teal.widgets::standard_layout(
178	1x	output = teal.widgets::white_small_well(
179	1x	tags$div(
180	1x	tags$h4("Rendered report from Rmd"),
181	1x	if (allow_download) {
182	1x	downloadButton(
183	1x	ns("download_rmd"),
184	1x	sprintf("Download R Markdown file"),
185	1x	class = "btn-primary btn-sm"
186		)
187		},
188	1x	ui_transform_teal_data(ns("extra_transform"), transformators = extra_transform)
189		),
190	1x	tags$hr(),
191	1x	uiOutput(ns("rmd_output"))
192		),
193	1x	encoding = NULL,
194	1x	pre_output = args$pre_output,
195	1x	post_output = args$post_output
196		)
197		}
198
199		# Server function for the rmarkdown module
200		srv_rmarkdown <- function(id, data, rmd_content, allow_download, extra_transform) {
201	8x	checkmate::assert_class(data, "reactive")
202	8x	checkmate::assert_class(isolate(data()), "teal_data")
203	8x	moduleServer(id, function(input, output, session) {
204	8x	pre_decorated_q_r <- reactive({
205	8x	data_q <- req(data())
206	8x	teal.reporter::teal_card(data_q) <- c(
207	8x	teal.reporter::teal_card(data_q),
208	8x	teal.reporter::teal_card("## Module's output(s)")
209		)
210	8x	data_q
211		})
212
213	8x	q_r <- data_with_output_decorated <- teal::srv_transform_teal_data(
214	8x	"extra_transform",
215	8x	data = pre_decorated_q_r,
216	8x	transformators = extra_transform
217		)
218
219	8x	if (allow_download) {
220	8x	output$download_rmd <- downloadHandler(
221	8x	filename = function() sprintf("from_teal_module-%s.Rmd", format(Sys.time(), "%Y%m%d_%H%M")),
222	8x	content = function(file) {
223		# find the end of the YAML header or start of the file
224		# and insert the contents of teal.code::get_code(q_r())
225	1x	yaml_end <- which(rmd_content == "---")[2]
226	1x	insert_pos <- if (!is.na(yaml_end)) yaml_end else 0
227	1x	note_lines <- c(
228		"",
229	1x	"### Pre-processing data",
230		"",
231	1x	"The following code chunk was automatically added by the teal markdown module.",
232	1x	"It shows how to generate the data used in this report.",
233		"",
234	1x	"```{r}",
235	1x	teal.code::get_code(q_r()),
236		"```",
237		""
238		)
239	1x	rmd_content <- append(rmd_content, note_lines, after = insert_pos)
240	1x	writeLines(rmd_content, con = file)
241		},
242	8x	contentType = "text/plain"
243		)
244		}
245
246	8x	clean_up_r <- shiny::reactiveVal(list())
247		# Can only clean on sessionEnded as temporary files are needed for the reporter
248		# during session
249	8x	onSessionEnded(function() {
250	8x	logger::log_debug("srv_rmarkdown: cleaning up temporary folders.", namespace = "teal.modules.general")
251	8x	lapply(shiny::isolate(clean_up_r()), function(f) f())
252	8x	}, session)
253
254	8x	rendered_path_r <- reactive({
255	8x	datasets <- rlang::env_clone(
256	8x	as.environment(req(q_r())),
257	8x	parent = new.env() # Ensuring a clean parent environment that can load libraries
258	8x	) # Clone to use unlocked environment
259	8x	temp_dir <- tempfile(pattern = "rmd_")
260	8x	dir.create(temp_dir, showWarnings = FALSE, recursive = TRUE)
261	8x	temp_rmd <- tempfile(pattern = "rmarkdown_module-", tmpdir = temp_dir, fileext = ".Rmd")
262
263		# Schedule cleanup of temp files when reactive is re-executed
264	8x	shiny::isolate({
265	8x	old_clean_up <- clean_up_r()
266	8x	clean_up_r(c(old_clean_up, function() unlink(temp_dir, recursive = TRUE)))
267		})
268	8x	writeLines(rmd_content, con = temp_rmd)
269
270	8x	tryCatch(
271		{
272	8x	result <- rmarkdown::render(
273	8x	temp_rmd,
274	8x	output_format = rmarkdown::md_document(
275	8x	variant = "markdown",
276	8x	standalone = TRUE,
277	8x	dev = "png"
278		),
279	8x	envir = datasets,
280	8x	quiet = TRUE,
281	8x	runtime = "static"
282		)
283	7x	temp_rmd_files <- sprintf("%s_files", tools::file_path_sans_ext(temp_rmd))
284	7x	if (!dir.exists(temp_rmd_files)) {
285	7x	dir.create(temp_rmd_files, showWarnings = FALSE, recursive = TRUE) # Create anyway as it is expected
286		}
287	7x	result
288		},
289	8x	error = function(e) {
290	1x	warning("Error rendering RMD file: ", e$message) # verbose error in logs
291	1x	e
292		}
293		)
294		})
295
296	8x	rendered_html_r <- reactive({
297	6x	output_path <- req(rendered_path_r())
298	6x	validate(
299	6x	need(inherits(output_path, "character"), "Error rendering RMD file. Please contact the app developer.")
300		)
301	6x	shiny::includeMarkdown(output_path)
302		})
303
304	8x	output$rmd_output <- renderUI(rendered_html_r())
305
306	8x	result <- reactive({
307	5x	out_data <- q_r()
308	5x	report_doc <- .markdown_internal(rendered_path_r(), rendered_html_r())
309	4x	teal.reporter::teal_card(out_data) <- c(
310	4x	teal.reporter::teal_card(out_data), report_doc
311		)
312	4x	out_data
313		})
314	8x	result
315		})
316		}
317
318		#' Create internal markdown object for use in reporter
319		#'
320		#' Creates an object of class `markdown_internal` that contains the
321		#' content of a markdown file.
322		#'
323		#' This package registers S3 methods for `toHTML` and `to_rmd` for this class to
324		#' facilitate rendering in `teal.reporter`.
325		#'
326		#' @param markdown_file (`character(1)`) path to markdown file.
327		#' @param rendered_html (`shiny.tag`) rendered HTML content.
328		#'
329		#' @return `markdown_internal` object
330		#'
331		#' @keywords internal
332		.markdown_internal <- function(markdown_file, rendered_html) {
333	5x	base_file <- basename(markdown_file)
334
335		# Create new custom structure with contents and images in base64 as attribute
336	4x	structure(
337	4x	readLines(markdown_file),
338	4x	class = c("markdown_internal", "character"),
339	4x	parent_path = dirname(markdown_file),
340	4x	old_base_path = sprintf("%s_files/", tools::file_path_sans_ext(base_file)),
341	4x	cached_html = rendered_html
342		)
343		}
344
345		#' @describeIn dot-markdown_internal Custom [tools::toHTML()] method for markdown_internal class that
346		#' uses a cached rendering of the module.
347		#' @inheritParams tools::toHTML
348		#' @param ... Arguments that will be passed to the next method.
349		#' @exportS3Method tools::toHTML
350		toHTML.markdown_internal <- function(x, ...) {
351	2x	cached_html <- attr(x, "cached_html", exact = TRUE)
352	2x	if (!is.null(cached_html)) {
353	1x	return(cached_html)
354		}
355	1x	NextMethod(unclass(x), ...)
356		}
357
358		#' @describeIn dot-markdown_internal Custom [teal.reporter::to_rmd()] method for `markdown_internal`
359		#' object will be used to render the report.
360		#' @inheritParams teal.reporter::to_rmd
361		#' @param figures_dir (`character(1)`) directory where the R markdown auxiliary files will be saved.
362		#' @exportS3Method teal.reporter::to_rmd
363		to_rmd.markdown_internal <- function(block, figures_dir = "figures", ...) {
364	1x	old_base_path <- attr(block, "old_base_path", exact = TRUE)
365	1x	parent_path <- attr(block, "parent_path", exact = TRUE)
366	1x	new_base_path <- file.path(figures_dir, old_base_path)
367
368		# Copy figures from old path to new location
369	1x	dir.create(figures_dir, showWarnings = FALSE, recursive = TRUE)
370	1x	file.copy(file.path(parent_path, old_base_path), figures_dir, recursive = TRUE)
371
372		# Change the image paths in the markdown content
373	1x	block <- gsub(pattern = old_base_path, replacement = new_base_path, x = block, fixed = TRUE)
374	1x	NextMethod(unclass(block), ...)
375		}

1		#' `teal` module: Distribution analysis
2		#'
3		#' Module is designed to explore the distribution of a single variable within a given dataset.
4		#' It offers several tools, such as histograms, Q-Q plots, and various statistical tests to
5		#' visually and statistically analyze the variable's distribution.
6		#'
7		#' @inheritParams teal::module
8		#' @inheritParams teal.widgets::standard_layout
9		#' @inheritParams shared_params
10		#'
11		#' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
12		#' Variable(s) for which the distribution will be analyzed.
13		#' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
14		#' Categorical variable used to split the distribution analysis.
15		#' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
16		#' Variable used for faceting plot into multiple panels.
17		#' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`).
18		#' Defaults to density (`FALSE`).
19		#' @param bins (`integer(1)` or `integer(3)`) optional, specifies the number of bins for the histogram.
20		#' - When the length of `bins` is one: The histogram bins will have a fixed size based on the `bins` provided.
21		#' - When the length of `bins` is three: The histogram bins are dynamically adjusted based on vector of `value`, `min`,
22		#' and `max`.
23		#' Defaults to `c(30L, 1L, 100L)`.
24		#'
25		#' @param ggplot2_args `r roxygen_ggplot2_args_param("Histogram", "QQplot")`
26		#'
27		#' @inherit shared_params return
28		#'
29		#' @section Decorating Module:
30		#'
31		#' This module generates the following objects, which can be modified in place using decorators::
32		#' - `histogram_plot` (`ggplot`)
33		#' - `qq_plot` (`ggplot`)
34		#'
35		#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
36		#' The name of this list corresponds to the name of the output to which the decorator is applied.
37		#' See code snippet below:
38		#'
39		#' ```
40		#' tm_g_distribution(

1		#' `teal` module: Missing data analysis
2		#'
3		#' This module analyzes missing data in `data.frame`s to help users explore missing observations and
4		#' gain insights into the completeness of their data.
5		#' It is useful for clinical data analysis within the context of `CDISC` standards and
6		#' adaptable for general data analysis purposes.
7		#'
8		#' @inheritParams teal::module
9		#' @inheritParams shared_params
10		#' @param parent_dataname (`character(1)`) Specifies the parent dataset name. Default is `ADSL` for `CDISC` data.
11		#' If provided and exists, enables additional analysis "by subject". For non-`CDISC` data, this parameter can be
12		#' ignored.
13		# nolint start: line_length.
14		#' @param ggtheme (`character`) optional, specifies the default `ggplot2` theme for plots. Defaults to `classic`.
15		#' @param ggplot2_args `r roxygen_ggplot2_args_param("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")`
16		# nolint end: line_length.
17		#'
18		#' @inherit shared_params return
19		#'
20		#' @section Decorating Module:
21		#'
22		#' This module generates the following objects, which can be modified in place using decorators:
23		#' - `summary_plot` (`ggplot`)
24		#' - `combination_plot` (`grob` created with [ggplot2::ggplotGrob()])
25		#' - `by_variable_plot` (`ggplot`)
26		#' - `by_subject_plot` (`ggplot`)
27		#'
28		#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
29		#' The name of this list corresponds to the name of the output to which the decorator is applied.
30		#' See code snippet below:
31		#'
32		#' ```
33		#' tm_missing_data(
34		#' ..., # arguments for module
35		#' decorators = list(
36		#' summary_plot = teal_transform_module(...), # applied only to `summary_plot` output
37		#' combination_plot = teal_transform_module(...), # applied only to `combination_plot` output
38		#' by_variable_plot = teal_transform_module(...) # applied only to `by_variable_plot` output
39		#' by_subject_plot = teal_transform_module(...) # applied only to `by_subject_plot` output
40		#' )

1		#' `teal` module: Outliers analysis
2		#'
3		#' Module to analyze and identify outliers using different methods
4		#' such as IQR, Z-score, and Percentiles, and offers visualizations including
5		#' box plots, density plots, and cumulative distribution plots to help interpret the outliers.
6		#'
7		#' @inheritParams teal::module
8		#' @inheritParams shared_params
9		#'
10		#' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
11		#' Specifies variable(s) to be analyzed for outliers.
12		#' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
13		#' specifies the categorical variable(s) to split the selected outlier variables on.
14		#' @param ggplot2_args `r roxygen_ggplot2_args_param("Boxplot", "Density Plot", "Cumulative Distribution Plot")`
15		#'
16		#' @inherit shared_params return
17		#'
18		#' @section Decorating Module:
19		#'
20		#' This module generates the following objects, which can be modified in place using decorators:
21		#' - `box_plot` (`ggplot`)
22		#' - `density_plot` (`ggplot`)
23		#' - `cumulative_plot` (`ggplot`)
24		#'
25		#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects.
26		#' The name of this list corresponds to the name of the output to which the decorator is applied.
27		#' See code snippet below:
28		#'
29		#' ```
30		#' tm_outliers(
31		#' ..., # arguments for module
32		#' decorators = list(
33		#' box_plot = teal_transform_module(...), # applied only to `box_plot` output
34		#' density_plot = teal_transform_module(...), # applied only to `density_plot` output
35		#' cumulative_plot = teal_transform_module(...) # applied only to `cumulative_plot` output
36		#' )
37		#' )
38		#' ```
39		#'
40		#' For additional details and examples of decorators, refer to the vignette